\ 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 ( rec# -- addr ) dup rec# ! RECORD ;
( make record current, read in, leave address )
\ 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 )
struct%
cell% field tag
char% 28 * field names ( "28" because we want it to fit 32 octets, low-level hack )
end-struct% rec%
rec% %size 200 ( number of records ) 400 ( starting block ) FILE demo ( file name )
( Here "file" consumes 3 cells. )
( And NOW we provide them explicitly. )
( Note, how this improves readability even if you remove all comments. )
( Actually, you can embed "%size" into "file" and have notation like "200 400 rec% file", )
( I think that it is better than above. )
( Style: Forth follows Lisp in the style in using "-" instead of "_". )
: input-name ( addr len rec# ) ( wait for name then store it in record )
record names 28 ROT MIN CMOVE UPDATE ;
: show-name ( rec# ) record names TYPE ; ( print name field )
: .REC ( rec# ) record CR dup tag @ 3 .r 2 spaces names 28 type ;
: clear-record ( rec# ) record rec% %size erase UPDATE ;
( No output is empty file, no need to special-case: )
: output open @ file-size @ 0 ?DO FORTH I .REC LOOP ENDIF cr ;
( "update" should be called _after_ you did actual update: )
: tag++ ( rec# ) record TAG 1 swap +! UPDATE ;
: rec_flush .REC FLUSH ;
: input
tag#+ input_name rec_flush ;
( no idea what it should do )
: dump_out 0 READ ADDRESS HEX 80 DUMP DECIMAL ;
( you must mean this: )
: dump ( rec# ) record rec% %size dump ;
demo
clear.data
output