\ Database design by Glen B. Haydon
decimal 1024 constant B/BUF \ define an old word from fig-forth
\ 8 utility Forth words------------------------------
variable REC# ( holds the current recorder number )
variable OPEN ( points to current file descriptor )
: LAYOUT ( leave bytes/record-2, and bytes/block-1 )
OPEN @ ( addr of open )
file-rec/buf ( addr' = 2 move down addr )
2@ ; ( get addr, addr' parameters )
( Now that you replaced hard-coded constant with field name, )
( you see that it leaves #rec/buf and "rec% %size". )
: READ ( n-th record, on stack, is made current )
( n --)
0 MAX ( n )
DUP OPEN @ file-size @ ( recno max-recno )
< 0= IF ." FILE ERROR " QUIT THEN ( bail out on invalid rec# )
REC# ! ; ( n ) \ save current recorder number
( Thus, this word simply checks that rec# is within limits: )
: read ( n ) dup 0 open @ file-size @ within 0= abort" file error" ;
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( See underlined, use exceptions where possible. They didn't exist back then. )
: RECORD ( rec# -- addr ) ( leave address of n-th record )
LAYOUT */MOD ( rem quot = offset into the record, offset into the file )
OPEN @ file-origin @ + ( block# ) BLOCK + ;
: ADDRESS ( leave address of the currernt record )
REC# @ RECORD ;
\ 3 defining Forth words------------------------------
: DFIELD CREATE ( create a data field )
OVER , + ( leaves file count for this definition )
DOES> ( leaves address )
@ ADDRESS + ;
( definition effect: offset length -- offset' )
( run time effect: -- addr )
: TFIELD CREATE ( create a text field )
OVER , DUP , + ( leaves fiel count for this definiton )
DOES> ( leaves: addr, count )
20 ADDRESS + SWAP ;
( definition effect: offset length -- offset' )
( run time effect: ... ??? see below )
( "20 address +" is suspicious, buffer overrun? )
( This should probably be "... does> 2@ address + swap", )
( because that way the word does leave "addr-len" pair, )
( and reuses stored information, as intended. )
( Yes, this _is_ buffer overrun, it is to be "... 2@ ..." )
struct%
cell field file-origin
cell field file-size ( in records )
cell field file-rec/buf ( number of records per storage block )
cell field file-rec-length ( record length )
end-struct file%
: FILE ( create a named storage allocation )
CREATE , ( origin block )
1+ , ( number of records in file )
DUP B/BUF OVER / * , ( # _bytes_ - NOT BYTES, RECORDS - per block )
,
DOES> OPEN ! ; ( when file name used, point to )
( its descriptor parameters. )
\ Double precision arithmetic words------------------------------
\ Inited words------------------------------
0 2 DFIELD TAG ( id field )
30 TFIELD names ( name field )
200 ( number of records ) 400 ( starting block ) FILE demo ( file name )
( Here "file" consumes 3 cells )
: input_name ( wait for name then store it in record )
names ROT MIN CMOVE UPDATE ;
: show_name ( print name field ) names TYPE ;
: .REC CR REC# @ 3 .R 2 spaces show_name ;
: clear.data 0 READ TAG 128 0 FILL UPDATE ;
: output 0 READ TAG @ dup 0= IF cr cr ." EMPTY FILE "
drop else 1+ 1 DO FORTH I READ .REC LOOP ENDIF cr cr ;
: tag#+ 0 READ TAG @ 1+ UPDATE DUP TAG ! READ ;
: rec_flush .REC FLUSH ;
: clear.data 0 READ TAG 128 0 FILL UPDATE ;
: output 0 READ TAG @ dup 0= IF cr cr ." EMPTY FILE "
drop else 1+ 1 DO FORTH I READ .REC LOOP ENDIF cr cr ;
: tag#+ 0 READ TAG @ 1+ UPDATE DUP TAG ! READ ;
: rec_flush .REC FLUSH ;
: input
tag#+ input_name rec_flush ;
: dump_out 0 READ ADDRESS HEX 80 DUMP DECIMAL ;
demo
clear.data
output