| 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 | \ Permission to use, copy, modify, and/or distribute this |
| 12 | \ software for any purpose with or without fee is hereby granted. |
| 13 | \ |
| 14 | \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL |
| 15 | \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED |
| 16 | \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL |
| 17 | \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR |
| 18 | \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING |
| 19 | \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF |
| 20 | \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF |
| 21 | \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
| 22 | \ |
| 23 | \ MOD: PLB 1/16/87 Use abort" instead of er.report. |
| 24 | \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal. |
| 25 | \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs. |
| 26 | \ MOD: PLB 7/31/88 Add USHORT and UBYTE. |
| 27 | \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive. |
| 28 | \ MOD: RDG 9/19/90 Add floating point member support. |
| 29 | \ MOD: PLB 6/10/91 Add RPTR |
| 30 | \ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S! |
| 31 | \ 941102 RDG port to pforth |
| 32 | \ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal. |
| 33 | \ 960710 PLB align long members for SUN |
| 34 | |
| 35 | ANEW TASK-MEMBER.FTH |
| 36 | decimal |
| 37 | |
| 38 | : FIND.BODY ( -- , pfa true | $name false , look for word in dict. ) |
| 39 | \ Return address of parameter data. |
| 40 | bl word find |
| 41 | IF >body true |
| 42 | ELSE false |
| 43 | THEN |
| 44 | ; |
| 45 | |
| 46 | \ Variables shared with object oriented code. |
| 47 | VARIABLE OB-STATE ( Compilation state. ) |
| 48 | VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class ) |
| 49 | 1 constant OB_DEF_CLASS ( defining a class ) |
| 50 | 2 constant OB_DEF_STRUCT ( defining a structure ) |
| 51 | |
| 52 | \ A member contains: |
| 53 | \ cell size of data in bytes (1, 2, cell) |
| 54 | \ cell offset within structure |
| 55 | |
| 56 | cell 1- constant CELL_MASK |
| 57 | cell negate constant -CELL |
| 58 | cell constant OB_OFFSET_SIZE |
| 59 | |
| 60 | : OB.OFFSET@ ( member_def -- offset ) @ ; |
| 61 | : OB.OFFSET, ( value -- ) , ; |
| 62 | : OB.SIZE@ ( member_def -- offset ) |
| 63 | ob_offset_size + @ ; |
| 64 | : OB.SIZE, ( value -- ) , ; |
| 65 | |
| 66 | ( Members are associated with an offset from the base of a structure. ) |
| 67 | : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time) |
| 68 | dup >r ( -- +-b , save #bytes ) |
| 69 | ABS ( -- |+-b| ) |
| 70 | ob-current-class @ ( -- b addr-space) |
| 71 | tuck @ ( as #b c , current space needed ) |
| 72 | over CELL_MASK and 0= ( multiple of cell? ) |
| 73 | IF |
| 74 | aligned |
| 75 | ELSE |
| 76 | over 1 and 0= ( multiple of two? ) |
| 77 | IF |
| 78 | even-up |
| 79 | THEN |
| 80 | THEN |
| 81 | swap over + rot ! ( update space needed ) |
| 82 | \ Save data in member definition. %M |
| 83 | ob.offset, ( save old offset for ivar ) |
| 84 | r> ob.size, ( store size in bytes for ..! and ..@ ) |
| 85 | ; |
| 86 | |
| 87 | \ Unions allow one to address the same memory as different members. |
| 88 | \ Unions work by saving the current offset for members on |
| 89 | \ the stack and then reusing it for different members. |
| 90 | : UNION{ ( -- offset , Start union definition. ) |
| 91 | ob-current-class @ @ |
| 92 | ; |
| 93 | |
| 94 | : }UNION{ ( old-offset -- new-offset , Middle of union ) |
| 95 | union{ ( Get current for }UNION to compare ) |
| 96 | swap ob-current-class @ ! ( Set back to old ) |
| 97 | ; |
| 98 | |
| 99 | : }UNION ( offset -- , Terminate union definition, check lengths. ) |
| 100 | union{ = NOT |
| 101 | abort" }UNION - Two parts of UNION are not the same size!" |
| 102 | ; |
| 103 | |
| 104 | \ Make members compile their offset, for "disposable includes". |
| 105 | : OB.MEMBER ( #bytes -- , make room in an object at compile time) |
| 106 | ( -- offset , run time for structure ) |
| 107 | CREATE ob.make.member immediate |
| 108 | DOES> ob.offset@ ( get offset ) ?literal |
| 109 | ; |
| 110 | |
| 111 | : OB.FINDIT ( <thing> -- pfa , get pfa of thing or error ) |
| 112 | find.body not |
| 113 | IF cr count type ." ???" |
| 114 | true abort" OB.FINDIT - Word not found!" |
| 115 | THEN |
| 116 | ; |
| 117 | |
| 118 | : OB.STATS ( member_pfa -- offset #bytes ) |
| 119 | dup ob.offset@ swap |
| 120 | ob.size@ |
| 121 | ; |
| 122 | |
| 123 | : OB.STATS? ( <member> -- offset #bytes ) |
| 124 | ob.findit ob.stats |
| 125 | ; |
| 126 | |
| 127 | : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object ) |
| 128 | ob.findit @ |
| 129 | ?literal |
| 130 | ; immediate |
| 131 | |
| 132 | \ Basic word for defining structure members. |
| 133 | : BYTES ( #bytes -- , error check for structure only ) |
| 134 | ob-state @ ob_def_struct = not |
| 135 | abort" BYTES - Only valid in :STRUCT definitions." |
| 136 | ob.member |
| 137 | ; |
| 138 | |
| 139 | \ Declare various types of structure members. |
| 140 | \ Negative size indicates a signed member. |
| 141 | : BYTE ( <name> -- , declare space for a byte ) |
| 142 | -1 bytes ; |
| 143 | |
| 144 | : SHORT ( <name> -- , declare space for a 16 bit value ) |
| 145 | -2 bytes ; |
| 146 | |
| 147 | : LONG ( <name> -- ) |
| 148 | cell bytes ; |
| 149 | |
| 150 | : UBYTE ( <name> -- , declare space for signed byte ) |
| 151 | 1 bytes ; |
| 152 | |
| 153 | : USHORT ( <name> -- , declare space for signed 16 bit value ) |
| 154 | 2 bytes ; |
| 155 | |
| 156 | |
| 157 | \ Aliases |
| 158 | : APTR ( <name> -- ) long ; |
| 159 | : RPTR ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001 |
| 160 | : ULONG ( <name> -- ) long ; |
| 161 | |
| 162 | : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar ) |
| 163 | [compile] sizeof() bytes |
| 164 | ; |