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