-\ @(#) member.fth 98/01/26 1.2\r
-\ This files, along with c_struct.fth, supports the definition of\r
-\ structure members similar to those used in 'C'.\r
-\\r
-\ Some of this same code is also used by ODE,\r
-\ the Object Development Environment.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license. The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ MOD: PLB 1/16/87 Use abort" instead of er.report.\r
-\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.\r
-\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.\r
-\ MOD: PLB 7/31/88 Add USHORT and UBYTE.\r
-\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.\r
-\ MOD: RDG 9/19/90 Add floating point member support.\r
-\ MOD: PLB 6/10/91 Add RPTR\r
-\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!\r
-\ 941102 RDG port to pforth\r
-\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.\r
-\ 960710 PLB align long members for SUN\r
-\r
-ANEW TASK-MEMBER.FTH\r
-decimal\r
-\r
-: FIND.BODY ( -- , pfa true | $name false , look for word in dict. )\r
-\ Return address of parameter data.\r
- bl word find\r
- IF >body true\r
- ELSE false\r
- THEN\r
-;\r
-\r
-\ Variables shared with object oriented code.\r
- VARIABLE OB-STATE ( Compilation state. )\r
- VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class )\r
- 1 constant OB_DEF_CLASS ( defining a class )\r
- 2 constant OB_DEF_STRUCT ( defining a structure )\r
-\r
-4 constant OB_OFFSET_SIZE\r
-\r
-: OB.OFFSET@ ( member_def -- offset ) @ ;\r
-: OB.OFFSET, ( value -- ) , ;\r
-: OB.SIZE@ ( member_def -- offset )\r
- ob_offset_size + @ ;\r
-: OB.SIZE, ( value -- ) , ;\r
-\r
-( Members are associated with an offset from the base of a structure. )\r
-: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)\r
- dup >r ( -- +-b , save #bytes )\r
- ABS ( -- |+-b| )\r
- ob-current-class @ ( -- b addr-space)\r
- tuck @ ( as #b c , current space needed )\r
- over 3 and 0= ( multiple of four? )\r
- IF\r
- aligned\r
- ELSE\r
- over 1 and 0= ( multiple of two? )\r
- IF\r
- even-up\r
- THEN\r
- THEN\r
- swap over + rot ! ( update space needed )\r
-\ Save data in member definition. %M\r
- ob.offset, ( save old offset for ivar )\r
- r> ob.size, ( store size in bytes for ..! and ..@ )\r
-;\r
-\r
-\ Unions allow one to address the same memory as different members.\r
-\ Unions work by saving the current offset for members on\r
-\ the stack and then reusing it for different members.\r
-: UNION{ ( -- offset , Start union definition. )\r
- ob-current-class @ @\r
-;\r
-\r
-: }UNION{ ( old-offset -- new-offset , Middle of union )\r
- union{ ( Get current for }UNION to compare )\r
- swap ob-current-class @ ! ( Set back to old )\r
-;\r
-\r
-: }UNION ( offset -- , Terminate union definition, check lengths. )\r
- union{ = NOT\r
- abort" }UNION - Two parts of UNION are not the same size!"\r
-;\r
-\r
-\ Make members compile their offset, for "disposable includes".\r
-: OB.MEMBER ( #bytes -- , make room in an object at compile time)\r
- ( -- offset , run time for structure )\r
- CREATE ob.make.member immediate\r
- DOES> ob.offset@ ( get offset ) ?literal\r
-;\r
-\r
-: OB.FINDIT ( <thing> -- pfa , get pfa of thing or error )\r
- find.body not\r
- IF cr count type ." ???"\r
- true abort" OB.FINDIT - Word not found!"\r
- THEN\r
-;\r
-\r
-: OB.STATS ( member_pfa -- offset #bytes )\r
- dup ob.offset@ swap\r
- ob.size@\r
-;\r
-\r
-: OB.STATS? ( <member> -- offset #bytes )\r
- ob.findit ob.stats\r
-;\r
-\r
-: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )\r
- ob.findit @\r
- ?literal\r
-; immediate\r
-\r
-\ Basic word for defining structure members.\r
-: BYTES ( #bytes -- , error check for structure only )\r
- ob-state @ ob_def_struct = not\r
- abort" BYTES - Only valid in :STRUCT definitions."\r
- ob.member\r
-;\r
-\r
-\ Declare various types of structure members.\r
-\ Negative size indicates a signed member.\r
-: BYTE ( <name> -- , declare space for a byte )\r
- -1 bytes ;\r
-\r
-: SHORT ( <name> -- , declare space for a 16 bit value )\r
- -2 bytes ;\r
-\r
-: LONG ( <name> -- )\r
- cell bytes ;\r
-\r
-: UBYTE ( <name> -- , declare space for signed byte )\r
- 1 bytes ;\r
-\r
-: USHORT ( <name> -- , declare space for signed 16 bit value )\r
- 2 bytes ;\r
-\r
-\r
-\ Aliases\r
-: APTR ( <name> -- ) long ;\r
-: RPTR ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001\r
-: ULONG ( <name> -- ) long ;\r
-\r
-: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )\r
- [compile] sizeof() bytes\r
-;\r
+\ @(#) member.fth 98/01/26 1.2
+\ This files, along with c_struct.fth, supports the definition of
+\ structure members similar to those used in 'C'.
+\
+\ Some of this same code is also used by ODE,
+\ the Object Development Environment.
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license. The pForth software
+\ code is provided on an "as is" basis without any warranty
+\ of any kind, including, without limitation, the implied
+\ warranties of merchantability and fitness for a particular
+\ purpose and their equivalents under the laws of any jurisdiction.
+\
+\ MOD: PLB 1/16/87 Use abort" instead of er.report.
+\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.
+\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.
+\ MOD: PLB 7/31/88 Add USHORT and UBYTE.
+\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.
+\ MOD: RDG 9/19/90 Add floating point member support.
+\ MOD: PLB 6/10/91 Add RPTR
+\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!
+\ 941102 RDG port to pforth
+\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.
+\ 960710 PLB align long members for SUN
+
+ANEW TASK-MEMBER.FTH
+decimal
+
+: FIND.BODY ( -- , pfa true | $name false , look for word in dict. )
+\ Return address of parameter data.
+ bl word find
+ IF >body true
+ ELSE false
+ THEN
+;
+
+\ Variables shared with object oriented code.
+VARIABLE OB-STATE ( Compilation state. )
+VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class )
+1 constant OB_DEF_CLASS ( defining a class )
+2 constant OB_DEF_STRUCT ( defining a structure )
+
+\ A member contains:
+\ cell size of data in bytes (1, 2, cell)
+\ cell offset within structure
+
+cell 1- constant CELL_MASK
+cell negate constant -CELL
+cell constant OB_OFFSET_SIZE
+
+: OB.OFFSET@ ( member_def -- offset ) @ ;
+: OB.OFFSET, ( value -- ) , ;
+: OB.SIZE@ ( member_def -- offset )
+ ob_offset_size + @ ;
+: OB.SIZE, ( value -- ) , ;
+
+( Members are associated with an offset from the base of a structure. )
+: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
+ dup >r ( -- +-b , save #bytes )
+ ABS ( -- |+-b| )
+ ob-current-class @ ( -- b addr-space)
+ tuck @ ( as #b c , current space needed )
+ over CELL_MASK and 0= ( multiple of cell? )
+ IF
+ aligned
+ ELSE
+ over 1 and 0= ( multiple of two? )
+ IF
+ even-up
+ THEN
+ THEN
+ swap over + rot ! ( update space needed )
+\ Save data in member definition. %M
+ ob.offset, ( save old offset for ivar )
+ r> ob.size, ( store size in bytes for ..! and ..@ )
+;
+
+\ Unions allow one to address the same memory as different members.
+\ Unions work by saving the current offset for members on
+\ the stack and then reusing it for different members.
+: UNION{ ( -- offset , Start union definition. )
+ ob-current-class @ @
+;
+
+: }UNION{ ( old-offset -- new-offset , Middle of union )
+ union{ ( Get current for }UNION to compare )
+ swap ob-current-class @ ! ( Set back to old )
+;
+
+: }UNION ( offset -- , Terminate union definition, check lengths. )
+ union{ = NOT
+ abort" }UNION - Two parts of UNION are not the same size!"
+;
+
+\ Make members compile their offset, for "disposable includes".
+: OB.MEMBER ( #bytes -- , make room in an object at compile time)
+ ( -- offset , run time for structure )
+ CREATE ob.make.member immediate
+ DOES> ob.offset@ ( get offset ) ?literal
+;
+
+: OB.FINDIT ( <thing> -- pfa , get pfa of thing or error )
+ find.body not
+ IF cr count type ." ???"
+ true abort" OB.FINDIT - Word not found!"
+ THEN
+;
+
+: OB.STATS ( member_pfa -- offset #bytes )
+ dup ob.offset@ swap
+ ob.size@
+;
+
+: OB.STATS? ( <member> -- offset #bytes )
+ ob.findit ob.stats
+;
+
+: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
+ ob.findit @
+ ?literal
+; immediate
+
+\ Basic word for defining structure members.
+: BYTES ( #bytes -- , error check for structure only )
+ ob-state @ ob_def_struct = not
+ abort" BYTES - Only valid in :STRUCT definitions."
+ ob.member
+;
+
+\ Declare various types of structure members.
+\ Negative size indicates a signed member.
+: BYTE ( <name> -- , declare space for a byte )
+ -1 bytes ;
+
+: SHORT ( <name> -- , declare space for a 16 bit value )
+ -2 bytes ;
+
+: LONG ( <name> -- )
+ cell bytes ;
+
+: UBYTE ( <name> -- , declare space for signed byte )
+ 1 bytes ;
+
+: USHORT ( <name> -- , declare space for signed 16 bit value )
+ 2 bytes ;
+
+
+\ Aliases
+: APTR ( <name> -- ) long ;
+: RPTR ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001
+: ULONG ( <name> -- ) long ;
+
+: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
+ [compile] sizeof() bytes
+;
projects / pforth / blobdiff