( COMPATIBLE STRUCTURES--IMPLEMENTATION
      Version:  1.0.1
         File:  cstruct.fs
       Author:  David.N.Williams@umich.edu
      License:  LGPL
Starting date:  July 4, 1994
Last revision:  June 15, 2000

The kernel obtained by turning off all options under CONDITIONAL
COMPILATION below is our ANS translation of Pocket Forth code by Randolph
M. Peters, which is under the LGPL with his copyright.  The rest of the
code is
)
\ Copyright (C) 2000 by David N. Williams
(
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.

Please see the file POLITENESS included with this distribution.

See the file cstruct.pdf for a description of the design and references.
See the file examples.fs for code examples.

In this file we follow the readability convention that Forth words
mentioned in comments are written as upper case.

The code in this document can be compiled by case-insensitive ANS Forth
implementations with the Core word set and the following words from the
following word sets:
)
\ Core Extension:    <>  ?DO  CASE  ENDCASE  ENDOF  FALSE  OF  TRUE U<
\		     UNUSED  VALUE
\ Double-Number:     2>R  D=  2LITERAL
\ File-Access:	     (  S"  INCLUDED
\ Locals:	     (LOCAL) TO
\ Locals Extension:  LOCALS|
\ Tools Extension:   [IF]  [ELSE]  [THEN]


\ *** CONDITIONAL COMPILATION
(
These flags represent orthogonal sections, which may be compiled or not
independently of each other.  Making all of these false gives a core with
only UNSTRUCT-CLASS and STRUCT-CLASS fields, equivalent to Peters'
implementation.  Choose your own values:
)
true value ATOMIC-FIELDS
true value C-ATOMIC-FIELDS	\ also used in machine.fs
true value EARLY-BINDING
true value ARRAY-FIELDS
true value UNIONS immediate
true value RIGHT-FIELD-SYNTAX
true value BIT-FIELDS		\ also used in machine.fs
(
We lied, the C-ATOMIC-FIELDS section requires the ATOMIC-FIELDS section. 
This orthogonalizes the choices:
)
C-ATOMIC-FIELDS [IF] true to ATOMIC-FIELDS [THEN]


\ *** PREAMBLE

cr .( Loading structure words, version 1.0.1, ) unused

s" machine.fs" included		\ system configuration parameters

: (r:  postpone ( ; immediate	\ return stack comment

\ Supposedly due to Charles Moore.
: under+  ( n1 n2 n3 -- n1+n3 n2 ) rot + swap ;

\ For simple structures used by this code, based on Peters' implementation.

0 value /parms

: parameter  ( "name")  ( -- )
\ "name" does:  ( addr -- addr+offset )
 create /parms dup , cell+ to /parms does> @ ( offset) + ;

1 cells constant cell
1 cells negate constant -cell

: uceil/  ( ux uy -- [ux+uy-1]/uy )
 dup >r + 1- 0 r> um/mod swap drop ;

: n-rounded  ( u n -- u' )
(
Round up the unsigned number u to a multiple of the unsigned number n.
)
 dup >r uceil/ r> * ;

\ Structure type structure elements:
parameter >type-size  \ WARNING!  /TYPE defined below knows that this is first.
parameter >type-class
parameter >type-align
parameter >#fields
parameter >field-parms

\ Field parameter structure elements:
0 to /parms
parameter >field-id
parameter >field-os
parameter >field-type
/parms value /field-parms

\ Data type class enumeration:
                   0 constant unstruct-class
                   1 constant struct-class
ATOMIC-FIELDS [IF] 2 constant atomic-class    [THEN]
ARRAY-FIELDS  [IF] 3 constant array-class     [THEN]
UNIONS        [IF] 4 constant union-class     [THEN]
BIT-FIELDS    [IF] 5 constant bit-field-class [THEN]


\ *** STRUCTURE WORDS
(
  STRUCT{  }STRUCT  UNION{  }UNION
  /TYPE  /ALIGN  MAKE-TYPE-INSTANCE  TYPEOF
  N-ALIGNED  UNSTRUCT  FIELD  ARRAY-FIELD  BIT-FIELD  BIT-PAD
  CCHAR  CWCHAR  CINT  CSHORT  CLONG  CPOINTER  CLLONG
  CFLOAT  CDOUBLE  CLDOUBLE
  MAKE-ATOMIC-TYPE  MAKE-ARRAY-TYPE  MAKE-UNSTRUCT-TYPE
  >SFA  >SFO  >SFA&TYPE  >SFO&TYPE

The order of the field parameters left on the stack by the field
constructors is chosen for storing into the structure table from the end
towards the beginning.  According to our layout of the table, that is
[field.parms] = [id os type].

Error checking is rudimentary or nonexistent, especially for field name
syntax errors.
)

\ General type words.

: /type   ( type -- type.sz )
(
Leave the total size in bytes required to store an instance of the data
type.
)
 @ ;  \ This word knows that >TYPE-SIZE adds zero.

: /align  ( type -- type.alignment )
(
Leave the alignment in address units required for an instance of the data
type.
)
 >type-align @ ;

: make-type-instance  ( type -- sda )
(
Allot pure data space for the data type, aligned according to the type, and
leave the address of the block of data space allotted.
)
 here over /align n-rounded here - allot
 here swap /type allot ;

: typeof  ( "name")  ( type -- )
\ "name" does:  ( -- dfa )
(
Create a type instance word for "name", store the type pointer type in its
data field, and allot /TYPE of type aligned space just after that, with
initial padding if necessary.  Upon execution, the type instance leaves its
dfa, pointing to the type pointer, on the stack.  When type has alignment
not guaranteed by Forth alignment, the type data might not begin one cell
after the dfa.  Type data access words have to take this into account.

TYPEOF can be used directly, but is used in this implementation as a factor
in instance making words for structure and union type classes.  The words
>SFA&TYPE and >SFA defined later do take care of any extra alignment.
)
 create dup , ( stype) make-type-instance ( sda) drop ;

\ Atomic data types.

ATOMIC-FIELDS [IF]

: make-atomic-type  ( size alignment -- adtype )
(
Make an unnamed instance of the type information for a new atomic type and
leave its address.  The information stored includes the data size and
alignment, and the ATOMIC-CLASS indicator.  The instance is Forth aligned.
)
 align here >r swap ( size) , atomic-class , ( align) , r> ;

: atomic-type  ( "name") ( size alignment -- )
\ "name" does:  ( -- adtype )
(
Make a named instance of the type information for a new atomic type, which
leaves the type pointer when executed.
)
 create make-atomic-type drop ;

[THEN]  \ END ATOMIC-FIELDS

C-ATOMIC-FIELDS [IF]
(
Is there a better naming system for CCHAR, etc.?  The user can make factors
like LONG-FIELD out of phrases like CLONG FIELD, but we would still want
explicit atomic type factors to use in phrases like 7 CLONG ARRAY-FIELD
GEORGE.
)
/CHAR /CALIGN		atomic-type cchar
/WCHAR /WCALIGN		atomic-type cwchar
/SHORT /SALIGN		atomic-type cshort
/INT /IALIGN		atomic-type cint
/LONG /LALIGN		atomic-type clong
/POINTER /PALIGN	atomic-type cpointer
/LONG-LONG /LLALIGN	atomic-type cllong
/FLOAT /FALIGN		atomic-type cfloat
/DOUBLE /DALIGN		atomic-type cdouble
/LONG-DOUBLE /LDALIGN	atomic-type cldouble

[THEN]  \ END C-ATOMIC-FIELDS

: struct{  ( -- 0 min.salign 0 )
(
Initialize a sequence of field definition parameters on the parameter stack
for eventual compilation by }STRUCT or }UNION into a table in the data
field of a structure type word.  From left to right, the quantities on the
stack are initial values for [#flds salign os], the number of fields,
structure alignment, and field offset.  These quantities are updated by the
field constructors.
)
 0 /MIN-ALIGN 0 ;

UNIONS [IF]

: union{  ( -- 0 min.salign 0 )
 struct{ ;

[THEN]  \ END UNIONS

: token  ( "name")  ( -- id )
\ "name" does:  ( -- id )
(
Implementation factor in structure field words.  Parse "name" delimited by
white space on the current line.  If "name" is not found in the search
order, create an entry for "name" in the word list of current definitions
so that its execution leaves a unique id [identifying number].  It is an
ambiguous error condition if "name" is found and corresponds to a word
whose execution does not simply leave a unique id.  The purpose is to map
structure field names onto unique numbers [tokens or id's].

Note: The following implementation uses the dfa of a dataless word as the
id, which we presume cannot be zero.
)
 >in @ >r	\ save input state
 bl word	\ read one word ahead
 dup c@ 0= ABORT" token: *** No label for new field id." \ only works at eoline
 find ( adr 0 | xt 1 | xt -1 )
 IF r> drop	\ leave input state advanced
  ( xt) execute ( dfa)
 ELSE r> >in !	\ restore input state, advance with CREATE
  ( adr) drop create here ( dfa) THEN ;

: n-aligned  ( salign u alignment -- salign' u' )
(
Align u upward to the nearest multiple of the strictly positive small
integer alignment, and leave salign' = max[salign, alignment].  The
alignment is allowed to be 1 and unlikely to be more than 16.
) 
 >r swap r@ max swap r>		( salign' u alignment)
 n-rounded ;

: field	( "name")  ( #flds salign os type --
			[field.parms] #flds+1 salign' os' )
(
Used to construct a field for any of the six type classes except
bit-fields, between STRUCT{ and }STRUCT or between UNION{ and }UNION.
Syntax:

	type.word FIELD name

where "type.word" leaves a type pointer, type, and "name" is the field
name, corresponding to a word, either created or already existing and
looked up by FIELD, which leaves a unique, nonzero id on the stack when
executed.

The input parameter os is the offset, the number of bytes in the fields
defined in the structure or union so far, including any padding; salign is
the structure alignment so far [maximum of alignments]; and #flds is the
number of fields defined since the last STRUCT{ or UNION{.

It is required that the field name "name" be reusable in other structures
or unions.  It is an ambiguous error condition if "name" already exists as
a non-id word and can be found in the search order when the syntax for
structures or unions expects a field id.

The content of the cells of output field parameters [field.parms] is
implementation dependent, but there must be enough information to construct
an entry in the structure or union table, yielding access to the field
identifier, the aligned field offset a[os], and type information.  In this
implementation, [field.parms]=[id a[os] type].

The updated alignment is salign'=max[salign,type.align]; and the updated
offset is a[os]+type.sz.
)
 locals| type os salign #flds |
 token salign os type /align n-aligned	( id salign' a[os])
 to os to salign 			( id)
 os type #flds 1+ salign		( id a[os] type #flds' salign')
 os type /type + ;		( id a[os] type #flds' salign' os')	

: make-unstruct-type  ( size -- ustype )
(
Make an unnamed instance of the unstructured field type and leave its
address.  The information stored includes the data size and alignment, and
the UNSTRUCT-CLASS indicator.  The instance is Forth aligned.
)
 align here swap ( size) , unstruct-class , 1 ( alignment) , ;

: unstruct  ( "name")  ( #flds salign os fld.sz --
			   [field.parms] #flds+1 salign os+fld.sz )
(
This field constructor defines an unstructured field of address units
between STRUCT{ and }STRUCT, or between UNION{ and }UNION.  Syntax:

	field.size.word UNSTRUCT name

Here "field.size.word" supplies fld.sz, and the remaining parameters have
the same meaning as in the specification of FIELD.  Note that UNSTRUCT does
not update the structure alignment, nor does it align the offset os.  In
our implementation UNSTRUCT builds an unstructured field type structure
instance with alignment 1 on the fly, leaves its ustype pointer, and calls
FIELD.

Upward alignment of the field to begin at a multiple of a strictly positive
number u can be enforced by the explicit syntax:

	u N-ALIGNED field.size.word UNSTRUCT name

The replacement of u N-ALIGNED by the Forth word ALIGNED is not allowed--
N-ALIGNED has the essential effect of updating the structure alignment. 
The alignment of u is not remembered in [field.parms].  In this
implementation, [field.parms]=[id os ustype].
)
 make-unstruct-type field ;

ARRAY-FIELDS [IF]

\ atype structure elements:
0 >#fields to /parms
parameter >ar-#elems	\ number of array elements
parameter >ar-elemtype	\ array element type

: make-array-type  ( #elems type -- atype )
(
Make an unnamed instance of the array type information and leave its
address.  The information stored includes the total data size and
alignment, the type of the array elements, the ARRAY-CLASS indicator, and
the number of array elements.  It is an ambiguous error condition if the
input type does not point to one of the five type classes excluding
bit-fields.  The instance is Forth aligned.
)
 dup >r /type		( #elems type.sz)	(r: type)
 over *			( #elems type.sz*#elems)
 r@ /align swap		( #elems type.align size)
 align here >r					(r: type atype)
 ( size) , array-class , ( align) , ( #elems) ,
 r> r> ( type) , ( atype) ;

: array-field  ( "name")  ( #flds salign os #elems type --
			      [field.parms] #flds+1 salign' a[os]+fld.sz )
(
Constructor for an array field between STRUCT{ and }STRUCT, or between
UNION{ and }UNION, for an array of #elem elements with type pointer type. 
The specification is the same as that in FIELD, if the two input parameters
#elem and type were replaced by a single atype pointer.  Syntax:

	#elements.word type.word ARRAY-FIELD name

In our implementation, ARRAY-FIELD builds an array field type structure
instance for #elem and type, leaves its atype pointer, and calls FIELD. If
such an array field type already exists as a named type, an alternate
syntax for building an array field is:

	atype.word FIELD name

In this implementation [field.parms]=[id a[os] atype].
)
 make-array-type field ;

[THEN]  \ END ARRAY-FIELDS

BIT-FIELDS [IF]

\ bftype structure elements:
0 >#fields to /parms
parameter >bf-max#bits	\ container type size in bits
parameter >bf-os	\ bit-field offset in bits
parameter >bf-#bits	\ bit-field size in bits

: container-type  ( type -- #bits align )
 dup /type BITS/UNIT * swap ( #bits type) /align ;

: make-bit-field-type  ( type #bits bit-os /containers -- bftype )
 locals| /containers bit-os #bits type |
 here ( bftype)
 /containers , bit-field-class ,
 type container-type ( alignment) , ( bf-max#bits) ,
 bit-os , #bits , ;

\ Embedding case enumeration:
0 constant 0-width
1 constant new-embed
2 constant overlap
3 constant old-embed

: embedding-case  ( prev.type type #bits -- case )
(
Compute which case of embedding in one or at most two containers is
required for #bits, depending on prev.type and type.
)
 locals| #bits type prev.type |
 prev.type >type-class @ bit-field-class <>
 IF new-embed	\ no prev bit-field
 ELSE
  prev.type >bf-#bits @ 0=
  IF new-embed	\ prev 0-width bit-field
  ELSE
   prev.type >bf-max#bits @ prev.type /align ( prev.max#bits prev.align)
   type container-type ( max#bits align) d=
   IF prev.type >bf-max#bits @ prev.type >bf-os @ -
    prev.type >bf-#bits @ - ?dup
    IF ( #bits-available) #bits <
     IF overlap
     ELSE old-embed
     THEN
    ELSE new-embed
    THEN
   ELSE new-embed
   THEN
  THEN
 THEN ;

\ We do not think factorization of the preceding or following word worthy
\ of contemplation.
 
: (bit-field)  ( prev.type #flds salign os container.type #bits id --
		   prev.type [field.parms] #flds+1 salign' os' )
(
The main factor in BIT-FIELD and BIT-PAD. See BIT-FIELD for the
specification.  In this implementation, prev.type is topmost cell on the
data stack in [prev.field.parms] = [prev.id prev.os prev.type].  There is a
possibility of stack underflow here, when #flds = 0.

With this implementation, every bit-field gets an unnamed bit-field type
instance made on the fly, to track the fact that bit-fields may have
arbitrary bit offsets in their containers.
)
 locals| id #bits type os salign #flds prev.type |
 prev.type	\ restore [prev.parms]
 type /type BITS/UNIT * #bits u<
 ABORT" (bit-field): ***Bit-field too large for embedding type."
 #bits 0= id and
 ABORT" (bit-field): ***Named bit-field has zero width."
 salign os type /align n-aligned	( salign' a[os])
 to os to salign			( )
\ There's no change in os or salign if prev.type is a bit-field with the
\ same container type.  Now start [field.parms].
 id os
\ Find the embedding case.
 #bits 0=
 IF 0-width
 ELSE #flds 0=
  IF new-embed	\ no previous field, start new container
  ELSE prev.type type #bits embedding-case
  THEN
 THEN
\ Adjust the os and set up the bftype, depending on the case, and set the
\ local os to the right os' for a following non-bit-field.
 CASE
  0-width OF ( a[os])	\ os' = os
   type #bits 0 ( bit.os) 0 ( /contain)
  ENDOF
  new-embed OF ( a[os])
   dup type /type + to os	\ os'= a[os] + /type
   type #bits 0 ( bit.os) type /type
  ENDOF
  old-embed OF ( a[os]) \ os' = a[os]
   type /type - 	\ os = a[os] - /type
   type #bits
   prev.type >bf-os @
   prev.type >bf-#bits @ + 	\ bit.os = prev.bit.os + prev.#bits
   type /type
  ENDOF
  overlap OF ( a[os])
   dup type /type + to os	\ os' = a[os] + /type 
   type /type -			\ os = a[os] - /type
   type #bits
   prev.type >bf-os @
   prev.type >bf-#bits @ + 	\ bit.os = (prev.bit.os 
   prev.type >bf-max#bits @ mod	\  + prev.#bits) mod max#bits
   type /type 2*
  ENDOF
 ENDCASE ( id os type #bits bit.os /containers)
 make-bit-field-type 	( id os bftype)
 #flds 1+ salign os ;	( id os bftype #flds' salign' os')

: bit-field  ( "name") ( [field.parms] #flds salign os container.type #bits --
			   [field.parms] [field.parms]' #flds+1 salign' os' )
(
If #flds = 0, [field.parms] is absent.  BIT-FIELD and BIT-PAD are the
constructors for named, respectively, unnamed bit-fields of size #bits
between STRUCT{ and }STRUCT, or between UNION{ and }UNION. Unnamed
bit-fields represent padding.  Only the size and alignment in the type
structure pointed to by container.type are relevant.  For C the intent is
usually an integral type.  For standard C, that has to be an int to be
legal.

BIT-FIELD and BIT-PAD have the same logical effects.  Note that:

1.  BIT-PAD generates zero as the unnamed name identifier in
[field.parms]'.

2.  Unnamed bit-fields survive as fields in the structure or union
definition table.

The field with #bits bits is embedded into one or at most two container
fields corresponding to container.type.  It is an ABORT error if #bits is
larger than the number of bits in one instance of the container type, or if
#bits is zero for BIT-FIELD.

If there is an immediately preceding bit-field of nonzero width, either
named or unnamed, with container field having the same size and alignment
as container.type and with unallocated bits in its last container field [of
the at most two], as many bits as possible are allocated there, and a new
container field is started for any remaining bits.  If there is no such
preceding field, all bits are allocated to a new container field.  In the
special case that #bits is zero for BIT-PAD, a new container field is
started, with no bits allocated, and zero total container field size.

The output [field.parms]' contains the usual field class and type
information, and must include or point to the total size in bytes of the at
most two container fields, the byte offset and alignment of the first of
the container field, the bit offset within that field, and #bits.  The
output parameters salign' and os' are unchanged from salign and os if no
new container field is started.  In the special case of BIT-PAD with a zero
width field, only salign is updated.  Otherwise os' = a[os] + type.size,
where a[os] is aligned with type.align.  In all cases, salign' =
max[salign, type.align]; and os' is ready for the next field constructor. 
Syntax:

	integral.type.word #bits.word BIT-FIELD name

corresponding [up to system dependence] to C phrases like

	char x:3;	int y:1;

of which only the second is standard.
)
 token (bit-field) ;

: bit-pad  ( [field.parms] #flds salign os type #bits --
	       [field.parms] [field.parms]' #flds+1 salign' os' )
(
Constructor for an unnamed bit-field of size #bits.  Same logical effect as
BIT-FIELD; see BIT-FIELD for the specification.  Syntax:

	integral.type.word #bits.word BIT-PAD

corresponding [up to system dependence] to C phrases like

	char :3;	int :1;		char :0;

of which only the second is standard.
)
 0 (bit-field) ;

[THEN]  \ END BIT-FIELDS

: make-field-table  ( [parms_1] ... [parms_n] n -- )
(
This is a factor in }STRUCT and }UNION. Store the groups of parameters into
the next available data space in order, with [parms_1] at the beginning and
[parms_n] at the end.
)
 dup  ( n) ,
 here ( start) swap /field-parms * allot here ( termination) cell -
 ?DO i ! -cell +LOOP ;

: }struct ( "name")  ( [parms_1] ... [parms_n] n salign data.sz -- )
\ "name" does:  ( -- stype )
(
Round data.sz up to a muliple of salign.  Create the structure type word
"name", and fill in the structure definition table in its data field.  When
executed, "name" leaves its stype [i.e., its dfa], identifying the
structure type.

The table includes the overall structure alignment max.align, and data.sz
rounded up according to max.align, with entries for each of the sets of
field definition parameters on the stack, sufficient to resolve nested
substructure offsets according to the specification of >SFA.  It must be
possible either to find or determine the absence of an entry for a named
field, given the address of the table and the field identifier.
)
 over n-rounded
 create ( data.sz) , struct-class , ( salign) ,
 make-field-table ;

UNIONS [IF]

: }union ( "name")  ( [parms_1] ... [parms_n] n salign data.sz -- )
\ "name" does:  ( -- utype )
(
Create the union type word "name", and fill in the union definition table,
clearing all field offsets and replacing data.sz with the maximum of the
field sizes rounded to a multiple of salign.  For bit-fields, it is the
offset of the first of the at most two container units that is zero, not
the bit offset of the bit-field within the first container.  A zero-width
[unnamed] bit-field contributes to the size of the union only through its
alignment.

Execution of the union type word "name" leaves its utype [i.e., its dfa],
identifying the union type.
)
 create here swap		( salign utype data.sz)
 ( data.sz) , union-class ,
 over				( salign utype salign)
 ( salign) , 2>r 		( )	(r: salign utype)
 make-field-table
 0 ( maxsize) r@ >#fields @ /field-parms * ( size-parms)
 r@ >field-parms dup under+	( maxsize fpa+size fpa)
 ?DO ( maxsize)
  0 i >field-os !		\ clear field offset
  i >field-type @ /type max	\ get max size so far
  /field-parms
 +LOOP ( maxsize)
 r> swap r> 			( utype maxsize salign) (r: )
 n-rounded swap ( size utype) !
;

[THEN]  \ END UNIONS

: find-field  ( id os stype|utype -- os' type )
(
Implementation factor for >SFO. Scan the [sub]structure or union table
stype or utype for the field identifier id.  Abort if id is not found.  If
it is found, leave os', which is os plus the offset of the found field, and
leave the field type pointer.  If the output type pointer is an stype or
utype, the output is ready for a FIND-FIELD at the next level of nesting in
the new structure table, with a subfield id expected one cell deeper than
os' on the stack.
)
 rot swap ( os id stype) dup >#fields @ swap >field-parms
 ( os id #fields fpa) rot ( os #fields fpa id)
 locals| id fpa |
 BEGIN ( #fields)
  dup 0= ABORT" find-field: ***Structure field not defined."
  1-
  fpa @ id <> WHILE fpa /field-parms + to fpa
 REPEAT ( #fields) drop  ( os)
  fpa >field-os @ + 	 ( os')
  fpa >field-type @ ;	 ( os' type)

: substruct?  ( type -- substruct.flag )
 >type-class @ struct-class
UNIONS [IF] over = swap union-class = or
[ELSE] =
[THEN] ;

: >sfo&type  ( id_m ... id_1 m stype|utype -- fld.os fld.type )
(
The identifier id_1 on the stack corresponds to a field of the structure
[or union] type stype [or utype].  If that field is a substructure [or
union], the substructure field identifier is id_2, etc., down to nesting
depth m.  It is an error if the chain of identifiers does not correspond to
a subchain of nested structures or unions beginning with stype or utype. 
The terminating field of a full chain must not be of structure or union
class.  A proper subchain ends at a substructure or union.  The type
pointer fld.type left by the word >SFO&TYPE is that of the field
corresponding to nesting through id_m; and for both words fld.os is the
offset of the field resolved that far, relative to the sda of an instance
of type stype or utype.  The special case m = 0 is allowed, in which case
there are no input identifiers on the stack, and the output offset fld.os
is zero.  For a full chain ending at a bit-field, the offset and type are
those of the first container field.
)
 swap dup
 IF			( [id's] stype m )
  >r (r: m ) 0 swap	( [id's] 0 stype) 
  r> 0 DO
   dup substruct? 0= ABORT" >sfo&type: ***Too many substructure identifiers."
   find-field		( [id's]' os' type')
  LOOP			( os' type')
 ELSE swap		( 0 stype)
 THEN ;

: >sfo  ( id_m ... id_1 m stype|utype -- fld.os )
 >sfo&type drop ;

: >sfa&type  ( id_m ... id_1 m stype|utype sda -- fld.addr fld.type )
(
The stack input to the left of the structure or union instance pointer sda
is the same as for >SFO and >SFO&TYPE, and the output type for >SFA&TYPE is
the same as for >SFO&TYPE.  Instead of an offset, these words leave the
address of the primitive or substructure field in the instance.  In other
words, fld.adr=sda+fld.os, and in case m=0 the output field address is the
instance pointer.  For a full chain ending at a bit-field, the address and
type are those of the first container field.

The words >SFO&TYPE and >SFA&TYPE evolved from a factorization of Peters'
implementation, which returned sizes instead of types.
)
 over /align n-rounded	\ ensure sda is aligned
 >r		( [id's] m stype)  (r: sda)
 >sfo&type	( os type)
 r> under+ ;	( sda+os type)

: >sfa  ( id_m ... id_1 m stype|utype sda -- fld.addr )
 >sfa&type drop ;

unused - . .( bytes.)
cr .( Loading structure extension words, version 1.01, )
unused


\ *** STRUCTURE EXTENSION WORDS
(
  {  }#
  {}STRUCTOF  {}STRUCTOF/
  STRUCTOF{}  }&  }&/
  ]&  ]&/  ]@  ]!  ]C@  ]C!  ]2@  ]2!  ]EXECUTE
)

\ Words for counting data stack parameters.

variable pdepth		\ intended only for { and }#

: {  ( -- )
(
Save the current parameter stack depth so it can be retrieved by the next
invocation of }#.  Note that { is a noop in situations where PDEPTH is
irrelevant.
)
 depth pdepth ! ;

: }#  ( -- n )
(
Leave the net number of items left on the parameter stack since the last
invocation of {.
)
 depth pdepth @ - ;

\ Left field syntax words.

: {}structof/  ( "name")  ( stype|utype -- )
\ "name" does: ( id_m ...  id_1 -- sfa sfsz ) 
(
Create a structure or union instance word for "name", store stype or utype
in its data field, and allot space there for a structure of type stype or
utype.  Upon execution, the structure instance "name" calculates the
parameter frame size on the assumption that PDEPTH was set just before the
first identifier pushed onto the stack, converts the subchain of field name
identifiers to the substructure field address of the data, and also leaves
the field size.  This word is included for compatibility with Peters'
NEW.STRUCT.
)
 typeof does> }# 1- swap dup @ swap cell+ >sfa&type /type ;

: {}structof  ( "name")  ( stype|utype -- )
\ "name" does:  ( id_m ...  id_1 -- sfa )
(
The same as {}STRUCTOF/, except the structure instance word "name" leaves
only the sfa and no size.
)
 typeof does> }# 1- swap dup @ swap cell+ >sfa ;

\ Right field syntax words.

RIGHT-FIELD-SYNTAX [IF]

0 value stype
0 value sda

: structof{}  ( "name")	 ( stype|utype -- )
(
Create a structure or union instance word for "name", store stype or utype
in its data field, and allot space there for a structure of type stype or
utype.  Upon execution, the structure instance "name" stores its stype or
utype and sda in STYPE and SDA, and initializes PDEPTH, ready for
subsequent id's to be pushed and followed by a closing structure access
operator, which will expect the following on the stack, plus the cached
stype and sda:  [ id_1 ...  id_m ]
)
 typeof does> dup @ to stype cell+ to sda { ;

: flip-parms  ( n_1 ... n_m  m -- n_m ... n_1 m )
(
We may have seen an idea like the following somewhere on comp.lang.forth. 
A right field syntax with the "unnatural" ordering of id's would have a
cleaner implementation in our scheme, making the word FLIP-PARMS
unnecessary.
)
 here >r dup >r (r: buf m) 0 ( m 0)
 ?DO , LOOP	\ buffer now contains d_m ... d_1
 r> ( m) here ( bufoffend) r> ( buf) rot >r ( bufoffend buf) (r: m)
 ?DO i @ cell +LOOP r> ( d_m ... d_1 m)
 dup cells negate allot ;

: }&/  ( id_1 ... id_m -- sfa sfsz )
 }# flip-parms stype sda >sfa&type /type ;

: }&  ( id_1 ...  id_m -- sfa )
 }&/ drop ;

[THEN]  \ END RIGHT-FIELD-SYNTAX

\ Early binding words.
(
These words all start by switching to compilation mode, where they compile
a simple action, based on a computation stacked from interpretation mode. 
See examples.fs for typical uses.  We hope the meanings are clear.
)
EARLY-BINDING [IF]

: ]&  ( n -- )		\ compilation
      ( -- n )		\ run
 ] postpone literal ;

: ]&/  ( n1 n2 -- )	\ compilation
       ( -- n1 n2 )	\ run
 ] postpone 2literal ;

: ]@  ( addr -- )	\ compilation
      ( -- n )		\ run
 ] postpone literal postpone @ ;

: ]!  ( addr -- )	\ compilation
      ( n -- )		\ run
 ] postpone literal postpone ! ;

: ]c@  ( addr -- )	\ compilation
       ( -- c )		\ run
 ] postpone literal postpone c@ ;

: ]c!  ( addr -- )	\ compilation
       ( c -- )		\ run
 ] postpone literal postpone c! ;

: ]2@  ( addr -- )	\ compilation
       ( -- n1 n2 )	\ run
 ] postpone literal postpone 2@ ;

: ]2!  ( addr -- )	\ compilation
       ( n1 n2 -- )	\ run
 ] postpone literal postpone 2! ;

: ]execute  ( xt -- )		\ compilation
	    ( i*x -- j*x )	\ run
 ] postpone literal postpone execute ;

[THEN]  \ END EARLY-BINDING
 
unused - . .( bytes.)