git.gag.com Git - debian/pforth/blob - 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, Devid 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         -4 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         -4 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       -4 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         -4 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
 181
 182 exists? F* [IF]
 183 \ 951112 Floating Point support
 184 : FLPT  ( <name> -- , declare space for a floating point value. )
 185      1 floats bytes
 186 ;
 187 : (S+F!)  ( val addr offset -- )  + f! ;
 188 : (S+F@)  ( addr offset -- val )  + f@ ;
 189
 190 : FS! ( value object <member> -- , fetch value from member )
 191     ob.stats?
 192     1 floats <> abort" FS@ with non-float!"
 193         state @
 194         IF
 195                 [compile] literal
 196                 compile (s+f!)
 197         ELSE (s+f!)
 198         THEN
 199 ; immediate
 200 : FS@ ( object <member> -- value , fetch value from member )
 201     ob.stats?
 202     1 floats <> abort" FS@ with non-float!"
 203         state @
 204         IF
 205                 [compile] literal
 206                 compile (s+f@)
 207         ELSE (s+f@)
 208         THEN
 209 ; immediate
 210 [THEN]
 211
 212 0 [IF]
 213 :struct mapper
 214     long map_l1
 215     long map_l2
 216     aptr map_a1
 217     rptr map_r1
 218     flpt map_f1
 219     short map_s1
 220     ushort map_s2
 221     byte map_b1
 222     ubyte map_b2
 223 ;struct
 224 mapper map1
 225
 226 : TT
 227         -500 map1 s! map_s1
 228         map1 s@ map_s1 -500 - abort" map_s1 failed!"
 229         -500 map1 s! map_s2
 230         map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
 231         -89 map1 s! map_b1
 232         map1 s@ map_b1 -89 - abort" map_s1 failed!"
 233         here map1 s! map_r1
 234         map1 s@ map_r1 here - abort" map_r1 failed!"
 235         -89 map1 s! map_b2
 236         map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
 237         23.45 map1 fs! map_f1
 238         map1 fs@ map_f1 f. ." =?= 23.45" cr
 239 ;
 240 ." Testing c_struct.fth" cr
 241 TT
 242 [THEN]