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