| 1 | \ @(#) c_struct.fth 98/01/26 1.2 |
| 2 | \ STRUCTUREs are for interfacing with 'C' programs. |
| 3 | \ Structures are created using :STRUCT and ;STRUCT |
| 4 | \ |
| 5 | \ This file must be loaded before loading any .J files. |
| 6 | \ |
| 7 | \ Author: Phil Burk |
| 8 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom |
| 9 | \ |
| 10 | \ The pForth software code is dedicated to the public domain, |
| 11 | \ and any third party may reproduce, distribute and modify |
| 12 | \ the pForth software code or any derivative works thereof |
| 13 | \ without any compensation or license. The pForth software |
| 14 | \ code is provided on an "as is" basis without any warranty |
| 15 | \ of any kind, including, without limitation, the implied |
| 16 | \ warranties of merchantability and fitness for a particular |
| 17 | \ purpose and their equivalents under the laws of any jurisdiction. |
| 18 | \ |
| 19 | \ MOD: PLB 1/16/87 Use abort" instead of er.report |
| 20 | \ MDH 4/14/87 Added sign-extend words to ..@ |
| 21 | \ MOD: PLB 9/1/87 Add pointer to last member for debug. |
| 22 | \ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..! |
| 23 | \ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long |
| 24 | \ fixed OB.COMPILE.+@/! for 0 offset |
| 25 | \ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE |
| 26 | \ MOD: RDG 9/19/90 Added floating point member support |
| 27 | \ MOD: PLB 12/21/90 Optimized ..@ and ..! |
| 28 | \ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed |
| 29 | \ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD |
| 30 | \ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR |
| 31 | \ 951112 PLB Added FS@ and FS! |
| 32 | \ This version for the pForth system. |
| 33 | |
| 34 | ANEW TASK-C_STRUCT |
| 35 | |
| 36 | decimal |
| 37 | \ STRUCT ====================================================== |
| 38 | : <:STRUCT> ( pfa -- , run time action for a structure) |
| 39 | [COMPILE] CREATE |
| 40 | @ even-up here swap dup ( -- here # # ) |
| 41 | allot ( make room for ivars ) |
| 42 | 0 fill ( initialize to zero ) |
| 43 | \ immediate \ 00001 |
| 44 | \ DOES> [compile] aliteral \ 00001 |
| 45 | ; |
| 46 | |
| 47 | \ Contents of a structure definition. |
| 48 | \ CELL 0 = size of instantiated structures |
| 49 | \ CELL 1 = #bytes to last member name in dictionary. |
| 50 | \ this is relative so it will work with structure |
| 51 | \ relocation schemes like MODULE |
| 52 | |
| 53 | : :STRUCT ( -- , Create a 'C' structure ) |
| 54 | \ Check pairs |
| 55 | ob-state @ |
| 56 | warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!" |
| 57 | ob_def_struct ob-state ! ( set pair flags ) |
| 58 | \ |
| 59 | \ Create new struct defining word. |
| 60 | CREATE |
| 61 | here ob-current-class ! ( set current ) |
| 62 | 0 , ( initial ivar offset ) |
| 63 | 0 , ( location for #byte to last ) |
| 64 | DOES> <:STRUCT> |
| 65 | ; |
| 66 | |
| 67 | : ;STRUCT ( -- , terminate structure ) |
| 68 | ob-state @ ob_def_struct = NOT |
| 69 | abort" ;STRUCT - Missing :STRUCT above!" |
| 70 | false ob-state ! |
| 71 | |
| 72 | \ Point to last member. |
| 73 | latest ob-current-class @ body> >name - ( byte difference of NFAs ) |
| 74 | ob-current-class @ cell+ ! |
| 75 | \ |
| 76 | \ Even up byte offset in case last member was BYTE. |
| 77 | ob-current-class @ dup @ even-up swap ! |
| 78 | ; |
| 79 | |
| 80 | \ Member reference words. |
| 81 | : .. ( object <member> -- member_address , calc addr of member ) |
| 82 | ob.stats? drop state @ |
| 83 | IF ?dup |
| 84 | IF [compile] literal compile + |
| 85 | THEN |
| 86 | ELSE + |
| 87 | THEN |
| 88 | ; immediate |
| 89 | |
| 90 | |
| 91 | : (S+C!) ( val addr offset -- ) + c! ; |
| 92 | : (S+W!) ( val addr offset -- ) + w! ; |
| 93 | : (S+!) ( val addr offset -- ) + ! ; |
| 94 | : (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; |
| 95 | |
| 96 | : compile+!bytes ( offset size -- ) |
| 97 | \ ." compile+!bytes ( " over . dup . ." )" cr |
| 98 | swap [compile] literal \ compile offset into word |
| 99 | CASE |
| 100 | cell OF compile (s+!) ENDOF |
| 101 | 2 OF compile (s+w!) ENDOF |
| 102 | 1 OF compile (s+c!) ENDOF |
| 103 | -cell OF compile (s+rel!) ENDOF \ 00002 |
| 104 | -2 OF compile (s+w!) ENDOF |
| 105 | -1 OF compile (s+c!) ENDOF |
| 106 | true abort" s! - illegal size!" |
| 107 | ENDCASE |
| 108 | ; |
| 109 | |
| 110 | : !BYTES ( value address size -- ) |
| 111 | CASE |
| 112 | cell OF ! ENDOF |
| 113 | -cell OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 |
| 114 | ABS |
| 115 | 2 OF w! ENDOF |
| 116 | 1 OF c! ENDOF |
| 117 | true abort" s! - illegal size!" |
| 118 | ENDCASE |
| 119 | ; |
| 120 | |
| 121 | \ These provide ways of setting and reading members values |
| 122 | \ without knowing their size in bytes. |
| 123 | : (S!) ( offset size -- , compile proper fetch ) |
| 124 | state @ |
| 125 | IF compile+!bytes |
| 126 | ELSE ( -- value addr off size ) |
| 127 | >r + r> !bytes |
| 128 | THEN |
| 129 | ; |
| 130 | : S! ( value object <member> -- , store value in member ) |
| 131 | ob.stats? |
| 132 | (s!) |
| 133 | ; immediate |
| 134 | |
| 135 | : @BYTES ( addr +/-size -- value ) |
| 136 | CASE |
| 137 | cell OF @ ENDOF |
| 138 | 2 OF w@ ENDOF |
| 139 | 1 OF c@ ENDOF |
| 140 | -cell OF @ if.rel->use ENDOF \ 00002 |
| 141 | -2 OF w@ w->s ENDOF |
| 142 | -1 OF c@ b->s ENDOF |
| 143 | true abort" s@ - illegal size!" |
| 144 | ENDCASE |
| 145 | ; |
| 146 | |
| 147 | : (S+UC@) ( addr offset -- val ) + c@ ; |
| 148 | : (S+UW@) ( addr offset -- val ) + w@ ; |
| 149 | : (S+@) ( addr offset -- val ) + @ ; |
| 150 | : (S+REL@) ( addr offset -- val ) + @ if.rel->use ; |
| 151 | : (S+C@) ( addr offset -- val ) + c@ b->s ; |
| 152 | : (S+W@) ( addr offset -- val ) + w@ w->s ; |
| 153 | |
| 154 | : compile+@bytes ( offset size -- ) |
| 155 | \ ." compile+@bytes ( " over . dup . ." )" cr |
| 156 | swap [compile] literal \ compile offset into word |
| 157 | CASE |
| 158 | cell OF compile (s+@) ENDOF |
| 159 | 2 OF compile (s+uw@) ENDOF |
| 160 | 1 OF compile (s+uc@) ENDOF |
| 161 | -cell OF compile (s+rel@) ENDOF \ 00002 |
| 162 | -2 OF compile (s+w@) ENDOF |
| 163 | -1 OF compile (s+c@) ENDOF |
| 164 | true abort" s@ - illegal size!" |
| 165 | ENDCASE |
| 166 | ; |
| 167 | |
| 168 | : (S@) ( offset size -- , compile proper fetch ) |
| 169 | state @ |
| 170 | IF compile+@bytes |
| 171 | ELSE >r + r> @bytes |
| 172 | THEN |
| 173 | ; |
| 174 | |
| 175 | : S@ ( object <member> -- value , fetch value from member ) |
| 176 | ob.stats? |
| 177 | (s@) |
| 178 | ; immediate |
| 179 | |
| 180 | exists? F* [IF] |
| 181 | \ 951112 Floating Point support |
| 182 | : FLPT ( <name> -- , declare space for a floating point value. ) |
| 183 | 1 floats bytes |
| 184 | ; |
| 185 | : (S+F!) ( val addr offset -- ) + f! ; |
| 186 | : (S+F@) ( addr offset -- val ) + f@ ; |
| 187 | |
| 188 | : FS! ( value object <member> -- , fetch value from member ) |
| 189 | ob.stats? |
| 190 | 1 floats <> abort" FS@ with non-float!" |
| 191 | state @ |
| 192 | IF |
| 193 | [compile] literal |
| 194 | compile (s+f!) |
| 195 | ELSE (s+f!) |
| 196 | THEN |
| 197 | ; immediate |
| 198 | : FS@ ( object <member> -- value , fetch value from member ) |
| 199 | ob.stats? |
| 200 | 1 floats <> abort" FS@ with non-float!" |
| 201 | state @ |
| 202 | IF |
| 203 | [compile] literal |
| 204 | compile (s+f@) |
| 205 | ELSE (s+f@) |
| 206 | THEN |
| 207 | ; immediate |
| 208 | [THEN] |
| 209 | |
| 210 | 0 [IF] |
| 211 | :struct mapper |
| 212 | long map_l1 |
| 213 | long map_l2 |
| 214 | short map_s1 |
| 215 | ushort map_s2 |
| 216 | byte map_b1 |
| 217 | ubyte map_b2 |
| 218 | aptr map_a1 |
| 219 | rptr map_r1 |
| 220 | flpt map_f1 |
| 221 | ;struct |
| 222 | mapper map1 |
| 223 | |
| 224 | ." compiling TT" cr |
| 225 | : TT |
| 226 | 123456 map1 s! map_l1 |
| 227 | map1 s@ map_l1 123456 - abort" map_l1 failed!" |
| 228 | 987654 map1 s! map_l2 |
| 229 | map1 s@ map_l2 987654 - abort" map_l2 failed!" |
| 230 | |
| 231 | -500 map1 s! map_s1 |
| 232 | map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!" |
| 233 | -500 map1 s! map_s2 |
| 234 | map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" |
| 235 | |
| 236 | -89 map1 s! map_b1 |
| 237 | map1 s@ map_b1 -89 - abort" map_s1 failed!" |
| 238 | here map1 s! map_r1 |
| 239 | map1 s@ map_r1 here - abort" map_r1 failed!" |
| 240 | -89 map1 s! map_b2 |
| 241 | map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" |
| 242 | 23.45 map1 fs! map_f1 |
| 243 | map1 fs@ map_f1 f. ." =?= 23.45" cr |
| 244 | ; |
| 245 | ." Testing c_struct.fth" cr |
| 246 | TT |
| 247 | [THEN] |