\ 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