Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/lib BLOCK.F, NONE, 1.1 CTYPE.F, NONE, 1.1 ENUM.F, NONE, 1.1 SoundVolume.f, NONE, 1.1 array.f, NONE, 1.1 binsearch.f, NONE, 1.1
|
From: Dirk B. <db...@us...> - 2006-10-28 09:07:12
|
Update of /cvsroot/win32forth/win32forth-stc/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21373/src/lib Added Files: BLOCK.F CTYPE.F ENUM.F SoundVolume.f array.f binsearch.f Log Message: Ported: block.f, ctype.f, enum.f, soundvolume.f, array.f and binsearch.f --- NEW FILE: CTYPE.F --- \ $Id: CTYPE.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $ ( ctype.f ) ( C-ish ctype macros, rendered in FORTH ) ( Placed in the public domain on 8aug96, by Jim Schneider ) \ August 9th, 1996 - 10:35 tjz slight modifications for Win32Forth cr .( Loading C-ish ctype macros... ) anew -ctype.f INTERNAL in-application 0x01 constant ctype_upper ( upper case letters ) 0x02 constant ctype_lower ( lower case letters ) 0x04 constant ctype_digit ( digit characters ) 0x08 constant ctype_ws ( white space ) 0x10 constant ctype_punct ( punctuation characters ) 0x20 constant ctype_hex ( hexadecimal digits ) 0x40 constant ctype_control ( control characters ) 0x80 constant ctype_graph ( is printable [ie., "graphic"] ) create ctype_array 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x048 c, ( 0x00-0x07 ) 0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x048 c, 0x040 c, 0x040 c, ( 0x08-0x0f ) 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, ( 0x10-0x17 ) 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, 0x040 c, ( 0x18-0x1f ) 0x088 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x20-0x27 ) 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x28-0x2f ) 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, 0x0a4 c, ( 0x30-0x37 ) 0x0a4 c, 0x0a4 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x38-0x3f ) 0x090 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x0a1 c, 0x081 c, ( 0x40-0x47 ) 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, ( 0x48-0x4f ) 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, 0x081 c, ( 0x50-0x57 ) 0x081 c, 0x081 c, 0x081 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, ( 0x58-0x5f ) 0x090 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x0a2 c, 0x082 c, ( 0x60-0x67 ) 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, ( 0x68-0x6f ) 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, 0x082 c, ( 0x70-0x77 ) 0x082 c, 0x082 c, 0x082 c, 0x090 c, 0x090 c, 0x090 c, 0x090 c, 0x040 c, ( 0x78-0x7f ) : ctype@ ( n -- x ) dup 0x7f > over 0< or if drop ctype_control else ctype_array + c@ then ; EXTERNAL : is-alpha ( n -- flag ) ctype@ [ ctype_upper ctype_lower or ] literal and 0<> ; : is-lower ( n -- flag ) ctype@ ctype_lower and 0<> ; : is-upper ( n -- flag ) ctype@ ctype_upper and 0<> ; : is-digit ( n -- flag ) ctype@ ctype_digit and 0<> ; : is-hex ( n -- flag ) ctype@ ctype_hex and 0<> ; : is-space ( n -- flag ) ctype@ ctype_ws and 0<> ; : is-forth-space ( n -- flag ) ctype@ [ ctype_ws ctype_control or ] literal and 0<> ; : is-punct ( n -- flag ) ctype@ ctype_punct and 0<> ; : is-alnum ( n -- flag ) ctype@ [ ctype_upper ctype_lower ctype_digit or or ] literal and 0<> ; : is-print ( n -- flag ) ctype@ ctype_graph and 0<> ; : is-graph ( n -- flag ) ctype@ [ ctype_punct ctype_upper ctype_lower ctype_digit or or or ] literal and 0<> ; : is-cntrl ( n -- flag ) ctype@ ctype_control and 0<> ; : tolower ( n -- n' ) dup is-upper if [ char a char A - ] literal + then ; : toupper ( n -- n' ) dup is-lower if [ char A char a - ] literal + then ; in-previous MODULE \s some test's cr 'a' is-alpha [if] .( ok ) [else] .( error ) [then] cr '1' is-alpha [if] .( error ) [else] .( ok ) [then] cr '1' is-digit [if] .( ok ) [else] .( error ) [then] cr 'a' is-digit [if] .( error ) [else] .( ok ) [then] cr 'a' is-lower [if] .( ok ) [else] .( error ) [then] cr 'A' is-lower [if] .( error ) [else] .( ok ) [then] cr 'A' is-upper [if] .( ok ) [else] .( error ) [then] cr 'a' is-upper [if] .( error ) [else] .( ok ) [then] cr 'a' toupper is-upper [if] .( ok ) [else] .( error ) [then] cr 'A' tolower is-lower [if] .( ok ) [else] .( error ) [then] --- NEW FILE: ENUM.F --- \ $Id: ENUM.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $ anew -enum.f in-system internal : not-a-comment? ( addr cnt -- f ) 2dup s" \" compare 0<> -rot \ not a \ comment ? s" //" compare 0<> and \ not a // comment ; external 1 value enum-increment \ *G Increment for \i enums \d. \ ** Note: In the Win32Forth Version 6.xx this value was called \i increment \d \ ** and it was in the \i HIDDEN \d directory. 100 value enum-value \ *G Start value for \i enums \d. : enum: ( -- ) \ *G Create a list of constants until terminating ; \ ** Note \i enum: \d will set \i enum-increment \d to 1 after executing. begin begin >in @ bl word swap >in ! c@ 0= while refill 0= \ get more stuff abort" Enum: - missing terminating ;" repeat >in @ bl word count s" ;" compare \ done enumerating if ; found while dup >in ! bl word count 2dup not-a-comment? if number? \ if a number if drop Constant \ allow setting specific value drop ( >in ) else 2drop ( from number? ) >in ! enum-value Constant \ create a constant value enum-increment +to enum-value then else 2drop >in ! interpret \ is a comment then repeat drop 1 to enum-increment ; \ restore default in-previous module \s Test 0 to enum-value \ set start value 2 to enum-increment \ set increment enum: foo1 \ create the constant's foo2 foo3 ; cr foo1 . cr foo2 . cr foo3 . --- NEW FILE: binsearch.f --- \ $Id: binsearch.f,v 1.1 2006/10/28 09:07:08 dbu_de Exp $ \ \ Binary Search by Charles Melice cr .( Loading Binary Search... ) anew -binsearch.f internal external DEFER GET-KEY ( index array -- key ) \ *G \i array \d sorted array of anything. \n \ ** \i index \d index \n \ ** \i key \d the value at array[index] DEFER B-COMPARE ( key1 key2 -- result ) \ *G if key1 < key2, return -1 \n \ ** if key1 > key2, return +1 \n \ ** else return 0. : BSEARCH ( key array count -- index flag ) \ *G When the key is not found, returns the position of the nearest greater key. \ ** Can be used to insert a new key in the sorted array. \ ** \ ** \i count \d count of elements in array. \n \ ** \i array \d SORTED array of anything. \n \ ** \i key \d the key we are searching for. \n \ ** \i flag \d TRUE if key was found. \n \ ** \i index \d effective else virtual key position in array. \n 1- 0 0 LOCALS| mid lo hi array key | BEGIN lo hi <= WHILE lo hi + 2/ TO mid key mid array GET-KEY B-COMPARE CASE -1 OF mid 1- TO hi ENDOF 1 OF mid 1+ TO lo ENDOF 0 OF mid TRUE EXIT ENDOF ENDCASE REPEAT lo hi MAX \ this computes the insertion point FALSE ; \ A non-local version by Wil Baden. \ : UNDER ( x y z -- z y ) \ ROT DROP SWAP ; \ \ : BSEARCH ( key array count -- index flag ) \ SWAP >R ( key count)( R: array) \ 0 SWAP ( key lo hi) \ \ BEGIN 2dup < WHILE \ 3dup + 2/ TUCK ( . . . mid key mid) \ R@ GET-KEY B-COMPARE ( . . . mid flag) \ 0> IF 1+ UNDER \ mid 1+ to lo \ ELSE NIP \ mid to hi \ THEN \ REPEAT ( key lo hi) \ \ NIP TUCK ( index key index) \ R> GET-KEY B-COMPARE 0= ; module \s Test. nostack create array here 0 , 3 , 12 , 23 , 45 , 66 , 88 , here swap - cell / constant NELEM :noname ( a b -- res ) 2dup > If 2drop 1 Exit Then < ; IS B-COMPARE :noname ( index array -- key ) swap cells + @ ; IS GET-KEY : TEST ( key -- ) array NELEM bsearch cr IF ." FOUND = " ELSE ." NOT FOUND, insert = " THEN . cr ; checkstack cr 12 test cr 13 test --- NEW FILE: SoundVolume.f --- \ SoundVolume.f \ \ Written: by Dirk Busch \ Licence: Public Domain anew -SoundVolume.f library winmm.dll internal external \ ----------------------------------------------------------------------------- \ Turn the sound on and off \ ----------------------------------------------------------------------------- : volume! ( left-sound-volume right-sound-volume -- ) \ W32F sound \ *G Set the volume level of the waveform-audio output device. depth 2 >= if 0max 99 min 65535 100 */ 65536 * swap 0max 99 min 65535 100 */ + 0 Call waveOutSetVolume drop else cr ." No enough parameters !!! " then ; : volume@ ( -- left-sound-volume right-sound-volume ) \ W32F sound \ *G Retrieves the current volume level of the waveform-audio output device. { \ sound-volume -- } &of sound-volume 0 call waveOutGetVolume MMSYSERR_NOERROR = if sound-volume word-split else 0 0 then ; : sound? ( -- f ) \ W32F sound \ *G Check if sound is on. volume@ 0> swap 0> or ; internal 0 value volume-left 0 value volume-right external : SoundOn ( -- ) \ W32F sound \ *G Turn the sound back on after turning it off. sound? 0= if volume-left volume-right volume! 0 to volume-right 0 to volume-left then ; : SoundOff ( -- ) \ W32F sound \ *G Turn sound off. sound? if volume@ to volume-right to volume-left 0 0 volume! then ; : SoundOnOff ( -- ) \ W32F sound \ *G Toggle sound sound? 0= if SoundOn else SoundOff then ; module \ *Z --- NEW FILE: array.f --- \ $Id: array.f,v 1.1 2006/10/28 09:07:08 dbu_de Exp $ cr .( Loading Array words... ) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ One dimensional Array words - Indices are counted from zero. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ anew -array.f internal external in-application : byte-array ( n1 -<name>- ) \ compile time ( -- a1 ) \ runtime create 1+ reserve ; : word-array ( n1 -<name>- ) \ compile time ( -- a1 ) \ runtime create 1+ 2* reserve ; : long-array ( n1 -<name>- ) \ compile time ( -- a1 ) \ runtime create 1+ cells reserve ; : double-array ( n1 -<name>- ) \ compile time ( -- a1 ) \ runtime create 1+ 2* cells reserve ; : #byte-array ( n1 -<name>- ) \ compile time 8-bits ( n1 -- byte ) \ runtime create 1+ reserve does> + c@ ; : ^#byte-array ( a1 -<name>- ) \ compile time 8-bits ( n1 -- byte ) \ runtime create , does> @ + c@ ; : #word-array ( n1 -<name>- ) \ compile time 16-bits ( n1 -- word ) \ runtime create 1+ 2* reserve does> swap 2* + w@ ; : ^#word-array ( n1 -<name>- ) \ compile time 16-bits ( n1 -- word ) \ runtime create , does> @ swap 2* + w@ ; : #long-array ( n1 -<name>- ) \ compile time 32-bits ( n1 -- long ) \ runtime create 1+ cells reserve does> swap cells+ @ ; : ^#long-array ( a1 -<name>- ) \ compile time 32-bits ( n1 -- long ) \ runtime create , does> @ swap cells+ @ ; : #double-array ( n1 -<name>- ) \ compile time 2 x 32-bits ( n1 -- long ) \ runtime create 1+ 2* cells reserve does> swap 2* cells+ 2@ ; : ^#double-array ( a1 -<name>- ) \ compile time 2 x 32-bits ( n1 -- long ) \ runtime create , does> @ swap 2* cells+ 2@ ; in-system : b#-> ( n1 n2 -<name>- ) \ store byte n1 into element n2 \ of byte array ' >body state @ if POSTPONE literal POSTPONE + POSTPONE c! else + c! then ; immediate : b#+> ( n1 n2 -<name>- ) \ store byte n1 into element n2 \ of byte array ' >body state @ if POSTPONE literal POSTPONE + POSTPONE c+! else + c+! then ; immediate : w#-> ( n1 n2 -<name>- ) \ store word n1 into element n2 \ of word array ' >body state @ if POSTPONE 2* POSTPONE literal POSTPONE + POSTPONE w! else swap 2* + w! then ; immediate : w#+> ( n1 n2 -<name>- ) \ store word n1 into element n2 \ of word array ' >body state @ if POSTPONE 2* POSTPONE literal POSTPONE + POSTPONE w+! else swap 2* + w+! then ; immediate : l#-> ( n1 n2 -<name>- ) \ store long n1 into element n2 \ of long array ' >body state @ if POSTPONE cells POSTPONE literal POSTPONE + POSTPONE ! else swap cells+ ! then ; immediate : l#+> ( n1 n2 -<name>- ) \ store long n1 into element n2 \ of long array ' >body state @ if POSTPONE cells POSTPONE literal POSTPONE + POSTPONE +! else swap cells+ +! then ; immediate : d#-> ( n1 n2 -<name>- ) \ store long n1 into element n2 \ of double array ' >body state @ if POSTPONE 2* POSTPONE cells POSTPONE literal POSTPONE + POSTPONE 2! else swap 2* cells+ 2! then ; immediate : d#+> ( n1 n2 -<name>- ) \ store long n1 into element n2 \ of double array ' >body state @ if POSTPONE 2* POSTPONE cells POSTPONE literal POSTPONE + POSTPONE 2+! else swap 2* cells+ 2+! then ; immediate in-application module --- NEW FILE: BLOCK.F --- \ $Id: BLOCK.F,v 1.1 2006/10/28 09:07:08 dbu_de Exp $ \ BLOCK.F Tom's Forth virtual block system. by Tom Zimmer cr .( Loading BLOCK...) \ *D doc \ *! p-block W32F block \ *T Using the Block Wordset \ *P Win32Forth implements a virtual block system, based on the ANSI standard Block \ ** and Block extension wordsets. \n \ ** The block words are not loaded by default and have to be included. The file \ ** BLOCK.F is in the lib folder (some older versions of W32F placed it in the extras \ ** folder). \n \ ** The constants B/BUF, and #BUFFERS control the block size, and the number of \ ** buffers the system uses. These are defaulted to 1024 byte blocks, and \ ** 8 buffers. A true LRU (least recently used) buffer allocation mechanism \ ** is used, implemented as a bubble up buffer stack. The least recently used \ ** buffer is always on the bottom of the stack. As buffers are used or \ ** re-used, they are bubbled immediately up to the top of the stack, destined \ ** to settle to the bottom of the stack if the same record is not accessed \ ** again. \n Blocks are stored in a blockfile (normally with the .blk extension, \ ** although some forths use .fb) which is set by the words set-blockfile, \ ** open-blockfile or create-blockfile and closed by close-blockfile. Only one \ ** blockfile is active at any one time, open-blockfile and create-blockfile \ ** automatically close the current one prior to setting themselves as the current \ ** blockfile. \n \ ** \b NOTE \d set-blockfile does not close the current blockfile. \ *P A sample block file BANNER.BLK has been included for your examination. \n \ ** type the following commands after loading BLOCK.F \n \ ** \n \ ** OPEN-BLOCKFILE DEMOS\BANNER.BLK \ ** 1 7 THRU \ ** \n \ ** This will load and run a simple demo. \n \ ** \n \ ** Type DEMO again to run it again after it has been loaded. only forth also definitions IN-APPLICATION \ needs 486asm.f \ load assembler if needed \ *S Glossary 1024 constant b/buf \ W32F Block extra \ *G Length of each block. 64 constant c/l \ W32F Block extra \ *G Number of characters per line. 8 constant #buffers \ W32F Block extra \ *G Number of block buffers. -1 value blockhandle \ W32F Block extra \ *G The handle of the current block file, or -1 if no current block file. variable blk ( -- a-addr ) \ ANSI Block \ *G a-addr is the address of a cell containing zero or the number of the mass-storage \ ** block being interpreted. If BLK contains zero, the input source is not a block \ ** and can be identified by SOURCE-ID, if SOURCE-ID is available. An ambiguous \ ** condition exists if a program directly alters the contents of BLK. variable scr ( -- a-addr ) \ ANSI Block ext \ *G a-addr is the address of a cell containing the block number of the block most \ ** recently listed. INTERNAL \ internal definitions variable cur_buffer# \ current buffer # of current block cur_buffer# off #buffers cells constant buflen variable rec_array b/buf #buffers * allot \ an array of blocks variable rec#s buflen allot \ block # array variable rec#updt buflen allot \ Update flags variable rec#use buflen allot \ block bubbleup stack variable rec#fil buflen allot \ hcb for each block \ n1 = buffer number \ a1 = address of buffer : buf#>bufaddr ( n1 --- a1 ) \ Calculate address a1 of buffer n1. b/buf * rec_array + ; \ n1 = buffer number \ a1 = buffer address : >rec#s ( n1 --- a1 ) \ return the buffer n1's record addr rec#s +cells ; \ n1 = buffer number \ a1 = buffer address : >rec#updt ( n1 --- a1 ) \ return the buffer n1's update addr rec#updt +cells ; \ n1 = buffer number \ a1 = buffer address : >rec#fil ( n1 --- a1 ) \ return the buffer n1's file addr rec#fil +cells ; : chkfil ( n1 --- n1 f1 ) \ verify file in bufer n1 is current dup dup 8 = if drop false exit else >rec#fil @ blockhandle = then ; : bubbleup ( n1 --- ) \ move buffer # n1 to end of list >r rec#use #buffers r@ lscan dup 0= abort" Buffer# number not in buffer list" 1- cells >r dup cell+ swap r> move \ move list down except first r> rec#use buflen + cell - ! ; \ stuff first at end of list. \ n1 = block we are looking for \ n2 = buffer # \ f1 = do we have it?, true if we do : ?gotrec ( n1 --- <n2> f1 ) \ Do we have block n1 in memory? rec#s #buffers rot lscan nip #buffers swap - ( tos is buffer # with matching block #) chkfil if true else drop false then ; \ n1 = block to positon to : pos_block ( n1 --- ) \ Set file pointer to block pos n1 0max b/buf * 0 blockhandle reposition-file drop ; \ a1 = destination address of read \ n1 = block number to read : read_block ( a1 n1 --- ) \ read block n1 to address a1 pos_block b/buf blockhandle read-file swap b/buf <> or abort" Error reading block" ; \ n1 = buffer number \ n2 = block number to write : write_block ( n1 n2 --- ) \ write block n1 to disk pos_block dup buf#>bufaddr b/buf rot >rec#fil @ write-file abort" Error writing block, probably out of disk space." ; EXTERNAL \ externally available definitions \ u = block # \ a-addr = bufadr : save-buffers ( -- ) \ ANSI Block \ *G Transfer the contents of each updated block buffer to mass storage. \ ** Mark all buffers as unmodified. #buffers 0 \ through all the buffers do rec#use @ >r \ find a buffer r@ bubbleup \ bump to highest priority r@ cur_buffer# ! \ set current buffer var r@ >rec#updt dup @ \ check update flag if off \ clear update flag r@ dup >rec#s @ \ get block # write_block \ write it else drop \ discard, already cleared then r>drop loop ; : buffer ( u -- a-addr ) \ ANSI Block \ *G a-addr is the address of the first character of the block buffer assigned to block u. \ ** The contents of the block are unspecified. An ambiguous condition exists if u is not \ ** an available block number. \n \ ** If block u is already in a block buffer, a-addr is the address of that block buffer. \n \ ** If block u is not already in memory and there is an unassigned buffer, a-addr is the \ ** address of that block buffer. \n \ ** If block u is not already in memory and there are no unassigned block buffers, \ ** unassign a block buffer. If the block in that buffer has been UPDATEd, transfer \ ** the block to mass storage. a-addr is the address of that block buffer. \ ** At the conclusion of the operation, the block buffer pointed to by a-addr is \ ** the current block buffer and is assigned to u. dup ?gotrec \ check if already present if >r drop \ buffer already assigned, save it else rec#use @ >r \ assign LRU buffer r@ >rec#updt dup @ \ check update flag if off \ clear update flag r@ dup >rec#s @ \ get block # write_block \ write it else drop \ discard, already cleared then r@ >rec#s ! \ set block # blockhandle r@ >rec#fil ! \ set the file hcb then r@ bubbleup \ bump to highest priority r@ cur_buffer# ! \ set current buffer var r> buf#>bufaddr ; \ calc buffer addr : empty-buffers ( -- ) \ ANSI Block ext \ *G Unassign all block buffers. Do not transfer the contents of any updated \ ** block buffer to mass storage. rec_array b/buf #buffers * erase rec#s buflen -1 fill rec#updt buflen erase rec#fil buflen erase rec#use #buffers 0 do i over ! cell+ \ initialize the bubbleup stack loop drop ; : flush ( -- ) \ ANSI Block \ *G Perform the function of SAVE-BUFFERS, then unassign all block buffers. save-buffers empty-buffers ; : update ( -- ) \ ANSI Block \ *G Mark the current block buffer as modified. An ambiguous condition exists if there \ ** is no current block buffer. \n \ ** Update does not write the block to the disc. cur_buffer# @ >rec#updt on ; \ u = block # to get \ a-addr is address of block # u : block ( u -- a-addr ) \ ANSI Block \ *G a-addr is the address of the first character of the block buffer assigned to \ ** mass-storage block u. An ambiguous condition exists if u is not an available \ ** block number. \n \ ** If block u is already in a block buffer, a-addr is the address of that block buffer. \n \ ** If block u is not already in memory and there is an unassigned block buffer, \ ** transfer block u from mass storage to an unassigned block buffer. a-addr is \ ** the address of that block buffer. \n \ ** If block u is not already in memory and there are no unassigned block buffers, unassign \ ** a block buffer. If the block in that buffer has been UPDATEd, transfer the block to \ ** mass storage and transfer block u from mass storage into that buffer. a-addr is the \ ** address of that block buffer. \n \ ** At the conclusion of the operation, the block buffer pointed to by a-addr is the \ ** current block buffer and is assigned to u. dup ?gotrec if nip dup >r buf#>bufaddr r@ cur_buffer# ! r> bubbleup else blockhandle 0< abort" No file open" dup buffer dup rot read_block then ; : list ( u -- ) \ ANSI Block ext \ *G Display block u in the console in a 16 line format. Store u in SCR. \n \ ** An error occurs if u is greater than the number of blocks in the current blockfile. dup scr ! block b/buf bounds do cr i c/l type c/l +loop ; : wipe ( u -- ) \ W32F Block extra \ *G Erase the specified block to blanks. buffer b/buf blank update ; : set-blockfile ( fileid -- ) \ W32F Block extra \ *G Make fileid the current blockfile. to blockhandle ; \ ---------------------------------------------------------------- \ The following words add capabities for dealing with blocks. \ See the documentation for what they do. \ ---------------------------------------------------------------- warning off : evaluate ( a1 n1 -- ) blk off evaluate ; : save-input ( -- xxx 8 ) save-input blk @ swap 1+ ; : restore-input ( xxx 8 -- f1 ) swap blk ! 1- restore-input >r blk @ 0> if blk @ block b/buf (source) 2! \ force back to block then r> ; : refill ( -- f1 ) blk @ 0= if refill else >in off blockhandle to source-id \ ?loading on blk @ 1+ b/buf block (source) 2! true then ; : \ ( -- ) blk @ 0= if postpone \ else >in @ c/l / 1+ c/l * >in ! then ; immediate warning on : blkmessage ( n1 -- ) blk @ 0> if base @ >r cr ." Error: " pocket count type space dup -2 = if drop msg @ count type else ." Error # " . then cr ." Block: " blk @ . ." at Line: " >in @ c/l / . cr blk @ block >in @ c/l / c/l * + c/l type blk off \ reset BLK cause noone else does!!! r> base ! else _message then ; ' blkmessage is message \ ---------------------------------------------------------------- \ -------- End of extended capabilities -------------------------- \ ---------------------------------------------------------------- : load ( i*x u -- j*x ) \ ANSI Block \ *G Save the current input-source specification. Store u in BLK (thus making block \ ** u the input source and setting the input buffer to encompass its contents), set \ ** >IN to zero, and interpret. When the parse area is exhausted, restore the prior \ ** input source specification. Other stack effects are due to the words LOADed. \ ** An ambiguous condition exists if u is zero or is not a valid block number. { loadblk \ incntr outcntr -- } save-input dup 1+ dup to incntr to outcntr begin >r -1 +to incntr incntr 0= until loadblk blk ! >in off blockhandle to source-id \ ?loading on blk @ block b/buf (source) 2! interpret begin r> -1 +to outcntr outcntr 0= until restore-input drop ; : thru ( i*x u1 u2 -- j*x ) \ ANSI Block ext \ *G LOAD the mass storage blocks numbered u1 through u2 in sequence. Other stack \ ** effects are due to the words LOADed. 1+ swap ?do i load loop ; : close-blockfile ( -- ) \ W32F Block extra \ *G Close the current blockfile, flushing any updated buffers. Set the current blockfile \ ** to no file. blockhandle -1 <> if flush blockhandle \ Roderick Mcban - February 11th, 2002 close-file drop then -1 to blockhandle ; : open-blockfile ( "<spaces>'filename'" ) \ W32F Block extra \ *G Close the current blockfile. Open the file and make it the current block file. close-blockfile /parse-word count r/w open-file abort" Failed to open Block File" set-blockfile empty-buffers ; : create-blockfile ( u "<spaces>'filename'" ) \ W32F Block extra \ *G Close the current blockfile. Create a file of u blocks long, initialise the \ ** blocks to blanks and make it the current blockfile. close-blockfile /parse-word count r/w create-file abort" Failed to create Block File" set-blockfile dup b/buf m* blockhandle resize-file abort" Unable to create a file of that size" empty-buffers 0 do i wipe loop flush ; : #blocks ( -- u ) \ W32F Block extra \ *G u is the number of blocks in the current blockfile. blockhandle file-size drop b/buf um/mod nip ; \ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ \ initialization of the block system \ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ empty-buffers \ Initialize the virtual memory arrays interpretively INTERNAL \ another internal definitions : virtual-init ( --- ) \ and during the system startup initialization -1 to blockhandle empty-buffers ; initialization-chain chain-add virtual-init MODULE \ end of the module get-current checkstack also environment definitions true constant BLOCK true constant BLOCK-EXT previous set-current \ *Z |
