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

   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]