\ 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 )
4 + ( addr' = 2 move down addr )
2@ ; ( get addr, addr' parameters )
: READ ( n-th record, on stack, is made current )
( n --)
0 MAX ( n )
DUP OPEN @ ( n n x )
2 + ( n n y=x+2 )
@ ( n n z=y @)
< ( n n z < ) \ set n < z
0= ( n -1 )
IF ." FILE ERROR " QUIT THEN
REC# ! ; ( n ) \ save current recorder number
: RECORD ( leave address of n-th record )
LAYOUT ( x1 n1 n2 )
*/MOD ( n3 n4 )
OPEN @ ( n3 n4 n5)
@ + ( n3 n4 n6 +)
BLOCK + ; ( n3 n7 block ) ( n3 n8 + )
: 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