Merge pull request #13 from philburk/fixrom

[pforth] / fth / member.fth

\ @(#) 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