\ Data Structures and Sample Code for Pocket Forth

\ Copyright (c) 1993 Randolph M. Peters

\ This library is free software; you can redistribute it and/or modify it
\ under the terms of the GNU Lesser General Public License as published by
\ the Free Software Foundation; either version 2.1 of the License, or (at
\ your option) any later version.

\ This library is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
\ General Public License for more details.

\ You should have received a copy of the GNU Lesser General Public License
\ along with this library; if not, write to the Free Software Foundation,
\ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.

\ What follows is sample code for data structures in pocket forth. It
\ compiles into about 1200 bytes. After these words are added to the
\ dictionary, a data structure can be built using the words "struct{",
\ "field" and "}struct" (see examples at the bottom of the listing.  Use
\ of the word "struct" allows structures to be nested.  This is the way it
\ works:
\ STRUCT{
\    10 field first
\    12 field last
\ }STRUCT name.struct	\ creates a structure type called name.struct

\ name.struct new.struct name \ instantiates an actual structure ('name')
\ first name [enter]
\ ok . .
\ 10 field.addr         \ puts field addr and size on stack
\ first name expect     \ allows you to enter data directly into the field

\ Please note that field identifiers are not reassigned, ie, the words
\ first and last above can be used as other structure field identifiers.
\ However, you cannot use a word not defined as a constant as a field
\ identifier.

\ Randolph M. Peters, M.D.
\ West Mifflin Primary Care Center
\ 1907 Lebanon Church Road
\ West Mifflin, PA 15122
\ (412) 650-2370
\ qwerty1965@aol.com
\ June, 2000

\ forget task : task ;
decimal 

: even dup 2 mod + ;
: -rot rot rot ;

: zero ( addr -- ) 0 swap ! ;
: @+ ( n addr -- ) dup @ rot + swap ! ;
: inc ( addr -- ) 1 swap @+ ;
: dec ( addr -- ) -1 swap @+ ;

2 constant bytes/cell
: cells bytes/cell * ;
: +cell bytes/cell + ;
: -cell bytes/cell - ;

: ?EXISTS ( -- addr t | f ) latest search ;
: [constant] header macro [compile] literal ,$ 34FC ,$ 4E75 ;

variable (ID)           (id) zero
: NEW.ID ( -- n ) (ID) inc (ID) @ ;
variable FOUND.FIELD    found.field zero
variable SOUGHT.FIELD   sought.field zero
variable PARAMETERS     parameters zero 
: #PARAMS  parameters @ ;
: PARAMETER 
   create #params , parameters inc 
   does> @ cells + @ ;
   
( field manipulation words )
parameter /OFFSET 
parameter /SIZE
parameter /TYPE
parameter /TOKEN
parameter /ID


( field compilation words )
: (FIELD)  ( zero -- )   drop 2 + 0 ;
: SAVE.FIELDS&OFFSET 2>r ; macro
: RESTORE.FIELDS&OFFSET 2r> ; macro 
: NEW.FIELD.ID  ( -- n )
   token ?exists if execute else new.id dup [constant] then ;
' (field) constant 'field
: FIELD  ( s.o s.f sz -- id tk ty sz os s.o s.f )
   even -rot 2>r 
   new.field.id  swap  'field  swap  0  swap 
   2r>  1+ >r 2dup + r>  ;


( structure compilation words )
: ,FIELD.DATA ( fieldparams... -- )
   ( os) , ( sz) , ( ty) , ( tk) , ( id) ,  ;
: BUILD.FIELD.TABLE ( fieldparams0 ... fieldparamsN N -- )
   0 do ,field.data loop ;
: STRUCT{ ( --  0 0 )
   0 ( offset )  0 ( fields ) ;
: }STRUCT 
   create swap , dup , build.field.table ;
   
   
( structure manipulation words )
: STRUCT.SIZE ( str -- n ) @ ;
: STRUCT.#FIELDS ( str -- n ) 1 cells + @ ;
: STRUCT.FIELD.TABLE ( str -- addr ) 
   2 cells + ;
: NTH.FIELD ( n str -- field.data.addr )
   struct.field.table  swap #params cells * +  ;
      
   
( structure execution words )
: FIND.FIELD ( id str.base.addr -- field.data.addr ) 
   found.field zero  swap sought.field !
   dup struct.#fields  0 do
      dup r  swap nth.field /id sought.field @ = 
      if r 1+ found.field ! then loop 
      found.field @ if found.field @ 1- swap nth.field
      else sought.field @ . ." isn't valid field" abort then ;   
: DO.FIELD ( str field.base.addr -- field.addr sz )
   >r    r /offset +  r /type  r /token execute 
   if else  r /size  then r> drop  ;
: (STRUCT) ( id base.addr str.addr -- field.addr sz )
   rot swap  find.field  do.field  -1 ;
: STRUCT ( s.o s.f str -- id tk ty sz os s.o s.f )
   -rot 2>r 
   new.field.id swap  [ ' (struct) literal ] swap
   dup struct.size 2r> 1+ >r 2dup + r> ;

: NEW.STRUCT ( struct.type -- )
   create dup , struct.size allot 
   does> ( id [] -- field.addr sz )
      swap over @ find.field  do.field ;
      
struct{
   12 field first
   16 field last
}struct name.struct

struct{
   2  field month
   2  field day
   2  field year
}struct date.struct

struct{
   name.struct  struct  name
   date.struct  struct  doa
   12           field   mrn
   64           field   precis 
}struct pt.struct


( demo words )
pt.struct new.struct patient

: demo
  first name patient ." First name? " expect
  last name patient ." Last name ? " expect
  ." Patient Name: " 
  first name patient type 
  last name patient type ;

demo