| 1 | \ @(#) member.fth 98/01/26 1.2\r |
| 2 | \ This files, along with c_struct.fth, supports the definition of\r |
| 3 | \ structure members similar to those used in 'C'.\r |
| 4 | \\r |
| 5 | \ Some of this same code is also used by ODE,\r |
| 6 | \ the Object Development Environment.\r |
| 7 | \\r |
| 8 | \ Author: Phil Burk\r |
| 9 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r |
| 10 | \\r |
| 11 | \ The pForth software code is dedicated to the public domain,\r |
| 12 | \ and any third party may reproduce, distribute and modify\r |
| 13 | \ the pForth software code or any derivative works thereof\r |
| 14 | \ without any compensation or license. The pForth software\r |
| 15 | \ code is provided on an "as is" basis without any warranty\r |
| 16 | \ of any kind, including, without limitation, the implied\r |
| 17 | \ warranties of merchantability and fitness for a particular\r |
| 18 | \ purpose and their equivalents under the laws of any jurisdiction.\r |
| 19 | \\r |
| 20 | \ MOD: PLB 1/16/87 Use abort" instead of er.report.\r |
| 21 | \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.\r |
| 22 | \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.\r |
| 23 | \ MOD: PLB 7/31/88 Add USHORT and UBYTE.\r |
| 24 | \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.\r |
| 25 | \ MOD: RDG 9/19/90 Add floating point member support.\r |
| 26 | \ MOD: PLB 6/10/91 Add RPTR\r |
| 27 | \ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!\r |
| 28 | \ 941102 RDG port to pforth\r |
| 29 | \ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.\r |
| 30 | \ 960710 PLB align long members for SUN\r |
| 31 | \r |
| 32 | ANEW TASK-MEMBER.FTH\r |
| 33 | decimal\r |
| 34 | \r |
| 35 | : FIND.BODY ( -- , pfa true | $name false , look for word in dict. )\r |
| 36 | \ Return address of parameter data.\r |
| 37 | bl word find\r |
| 38 | IF >body true\r |
| 39 | ELSE false\r |
| 40 | THEN\r |
| 41 | ;\r |
| 42 | \r |
| 43 | \ Variables shared with object oriented code.\r |
| 44 | VARIABLE OB-STATE ( Compilation state. )\r |
| 45 | VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class )\r |
| 46 | 1 constant OB_DEF_CLASS ( defining a class )\r |
| 47 | 2 constant OB_DEF_STRUCT ( defining a structure )\r |
| 48 | \r |
| 49 | 4 constant OB_OFFSET_SIZE\r |
| 50 | \r |
| 51 | : OB.OFFSET@ ( member_def -- offset ) @ ;\r |
| 52 | : OB.OFFSET, ( value -- ) , ;\r |
| 53 | : OB.SIZE@ ( member_def -- offset )\r |
| 54 | ob_offset_size + @ ;\r |
| 55 | : OB.SIZE, ( value -- ) , ;\r |
| 56 | \r |
| 57 | ( Members are associated with an offset from the base of a structure. )\r |
| 58 | : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)\r |
| 59 | dup >r ( -- +-b , save #bytes )\r |
| 60 | ABS ( -- |+-b| )\r |
| 61 | ob-current-class @ ( -- b addr-space)\r |
| 62 | tuck @ ( as #b c , current space needed )\r |
| 63 | over 3 and 0= ( multiple of four? )\r |
| 64 | IF\r |
| 65 | aligned\r |
| 66 | ELSE\r |
| 67 | over 1 and 0= ( multiple of two? )\r |
| 68 | IF\r |
| 69 | even-up\r |
| 70 | THEN\r |
| 71 | THEN\r |
| 72 | swap over + rot ! ( update space needed )\r |
| 73 | \ Save data in member definition. %M\r |
| 74 | ob.offset, ( save old offset for ivar )\r |
| 75 | r> ob.size, ( store size in bytes for ..! and ..@ )\r |
| 76 | ;\r |
| 77 | \r |
| 78 | \ Unions allow one to address the same memory as different members.\r |
| 79 | \ Unions work by saving the current offset for members on\r |
| 80 | \ the stack and then reusing it for different members.\r |
| 81 | : UNION{ ( -- offset , Start union definition. )\r |
| 82 | ob-current-class @ @\r |
| 83 | ;\r |
| 84 | \r |
| 85 | : }UNION{ ( old-offset -- new-offset , Middle of union )\r |
| 86 | union{ ( Get current for }UNION to compare )\r |
| 87 | swap ob-current-class @ ! ( Set back to old )\r |
| 88 | ;\r |
| 89 | \r |
| 90 | : }UNION ( offset -- , Terminate union definition, check lengths. )\r |
| 91 | union{ = NOT\r |
| 92 | abort" }UNION - Two parts of UNION are not the same size!"\r |
| 93 | ;\r |
| 94 | \r |
| 95 | \ Make members compile their offset, for "disposable includes".\r |
| 96 | : OB.MEMBER ( #bytes -- , make room in an object at compile time)\r |
| 97 | ( -- offset , run time for structure )\r |
| 98 | CREATE ob.make.member immediate\r |
| 99 | DOES> ob.offset@ ( get offset ) ?literal\r |
| 100 | ;\r |
| 101 | \r |
| 102 | : OB.FINDIT ( <thing> -- pfa , get pfa of thing or error )\r |
| 103 | find.body not\r |
| 104 | IF cr count type ." ???"\r |
| 105 | true abort" OB.FINDIT - Word not found!"\r |
| 106 | THEN\r |
| 107 | ;\r |
| 108 | \r |
| 109 | : OB.STATS ( member_pfa -- offset #bytes )\r |
| 110 | dup ob.offset@ swap\r |
| 111 | ob.size@\r |
| 112 | ;\r |
| 113 | \r |
| 114 | : OB.STATS? ( <member> -- offset #bytes )\r |
| 115 | ob.findit ob.stats\r |
| 116 | ;\r |
| 117 | \r |
| 118 | : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )\r |
| 119 | ob.findit @\r |
| 120 | ?literal\r |
| 121 | ; immediate\r |
| 122 | \r |
| 123 | \ Basic word for defining structure members.\r |
| 124 | : BYTES ( #bytes -- , error check for structure only )\r |
| 125 | ob-state @ ob_def_struct = not\r |
| 126 | abort" BYTES - Only valid in :STRUCT definitions."\r |
| 127 | ob.member\r |
| 128 | ;\r |
| 129 | \r |
| 130 | \ Declare various types of structure members.\r |
| 131 | \ Negative size indicates a signed member.\r |
| 132 | : BYTE ( <name> -- , declare space for a byte )\r |
| 133 | -1 bytes ;\r |
| 134 | \r |
| 135 | : SHORT ( <name> -- , declare space for a 16 bit value )\r |
| 136 | -2 bytes ;\r |
| 137 | \r |
| 138 | : LONG ( <name> -- )\r |
| 139 | cell bytes ;\r |
| 140 | \r |
| 141 | : UBYTE ( <name> -- , declare space for signed byte )\r |
| 142 | 1 bytes ;\r |
| 143 | \r |
| 144 | : USHORT ( <name> -- , declare space for signed 16 bit value )\r |
| 145 | 2 bytes ;\r |
| 146 | \r |
| 147 | \r |
| 148 | \ Aliases\r |
| 149 | : APTR ( <name> -- ) long ;\r |
| 150 | : RPTR ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001\r |
| 151 | : ULONG ( <name> -- ) long ;\r |
| 152 | \r |
| 153 | : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )\r |
| 154 | [compile] sizeof() bytes\r |
| 155 | ;\r |