git.gag.com Git - debian/pforth/blob - fth/c_struct.fth

   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