urflibs/struct.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; statically and dynamically allocated structures
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10
  11 (*
  12   each struct is a vocabulary (without a hash table, i don't expect
  13   structs to have enough fields to varrant using a hash table).
  14
  15   that vocabulary contains words with field names. such word does
  16   access to struct field (via "DOES>"), and also contains field
  17   info in pfa:
  18     offset
  19     size    ; this is unused yet, and always 4
  20     owner struct vocid
  21
  22   special predefined fields:
  23     @size -- returns total struct size, in bytes: MyStruct:@size
  24     @parent -- returns parent vocid or 0
  25     @self   -- returns self vocid
  26
  27   internally, each struct has 3 those fields preallocated as first 3 cells.
  28
  29   declaring structs:
  30     STRUCT:DEFINE MyStruct [ EXTENDS OtherStruct ]
  31       FIELD: a
  32       FIELD: b
  33     END-STRUCT MyStruct
  34
  35   using structs:
  36
  37     MyStruct STRUCT:NEW value stx -- dynamically allocated, creates dynamic memory handle
  38     ." orig a: " stx MyStruct:a . cr
  39     666 stx MyStruct:a!
  40     ." new a: " stx MyStruct:a . cr
  41
  42     ." size of a: " MyStruct size@ . cr
  43
  44     stx 69 MyStruct:a!
  45     ." new a: " stx MyStruct:a . cr
  46
  47     : stx-set-test  ( stx -- )  dup  666 MyStruct:b!  MyStruct:b . cr ;
  48     stx stx-set-test
  49
  50     MyStruct STRUCT:ALLOT TO stx
  51
  52     CREATE sst MyStruct:@size ALLOT CREATE; -- creates static struct
  53 *)
  54
  55 ;; create main vocab
  56 simple-vocabulary struct
  57 also struct definitions
  58
  59 ;; create vocab with hidden internal words
  60 simple-nested-vocabulary struct-internals
  61 also struct-internals definitions
  62
  63 ;; wordlist typeid for structs
  64 ;; this should use some central repository in the future
  65 0x029a_0069 constant (wl-struct-typeid)
  66
  67 ;; we'll save "CURRENT" in "DEFINE" here, to restore it in "END-STRUCT"
  68 0 value (saved-current)
  69
  70 ;; struct size offset in wordlist
  71 ;; -4 is typeid
  72 -2 cells constant (sofs-vocid-size)
  73
  74 ;; internal field offsets in *allocated* struct
  75 0 cells constant (sofs-size)
  76 1 cells constant (sofs-parent)
  77 2 cells constant (sofs-self)
  78 ;; size of all internal fields
  79 3 cells constant (sofs-internal-size)
  80
  81 ;; offsets from field word PFA
  82 0 cells constant (fofs-ofs)
  83 1 cells constant (fofs-size)
  84 2 cells constant (fofs-owner)
  85
  86
  87 ;; doer for main struct word
  88 ;; we don't need it to change context vocab
  89 : (struct-doer)  ( pfa -- vocid )  @ ;
  90
  91 ;; vocid utils
  92 : (vocid-struct-size@)  ( vocid -- size ) (sofs-vocid-size) + @ ;
  93 : (vocid-struct-size!)  ( size vocid -- ) (sofs-vocid-size) + ! ;
  94 : (vocid-struct?)  ( vocid -- bool )  (vocid-typeid@) (wl-struct-typeid) = ;
  95 : (word-struct?)  ( cfa -- bool )  @ ['] (struct-doer) cfa->pfa = ;
  96 : (addr-struct?)  ( addr/stx -- bool )
  97   dup (handle-addr?) if handle:typeid@
  98   else (sofs-self) + @ (vocid-typeid@) endif
  99   (wl-struct-typeid) =
 100 ;
 101
 102
 103 ;; create struct wordlist
 104 : (create-wlist)  ( -- vocid )
 105   ;; allocate some struct helper data
 106   ;;   -8: size-in-bytes
 107   ;; calculate our initial size
 108   (sofs-internal-size) forth:, ;; store initial size
 109   0 false forth:(new-wordlist)   ;; create wordlist without a hash table
 110   ;; setup type id
 111   (wl-struct-typeid) over (vocid-typeid!)
 112 ;
 113
 114
 115 ;; create new field in the current vocabulary
 116 ;; "CURRENT" must be a struct vocab
 117 : (create-field)  ( fofs doer-cfa addr count -- )
 118   forth:(new-word-flags) dup @ >r compiler:(wflag-protected) swap or!
 119   (create)
 120   swap forth:, ;; offset
 121   cell ,       ;; size
 122   current @ ,  ;; owner vocid
 123   create;
 124   cfa->pfa latest-cfa compiler:(set-doer)
 125   r> forth:(new-word-flags) !
 126 ;
 127
 128
 129 ;; check if the handle/address of the allocated struct is of a good type
 130 : (check-type)  ( stx vocid -- )
 131   over (addr-struct?) " allocated struct expected" ?not-error
 132   ;; get stx-self
 133   a>r swap >a (sofs-self) @a+ r>a  ( vocid parent-vocid )
 134   begin
 135     dup " invalid struct type" ?not-error
 136     2dup <>
 137   while
 138     (vocid-parent@)
 139   repeat
 140   2drop
 141 ;
 142
 143 ;; doers for user fields
 144
 145 ;; address register contains struct base
 146 : (@a-field-doer)  ( pfa -- value )
 147   a> over (fofs-owner) + @ (check-type)
 148   (fofs-ofs) + @ @a+
 149 ;
 150
 151 : (!a-field-doer)  ( value pfa -- value )
 152   a> over (fofs-owner) + @ (check-type)
 153   (fofs-ofs) + @ !a+
 154 ;
 155
 156 : (@field-doer)  ( stx pfa -- value )
 157   a>r swap >a (@a-field-doer) r>a
 158 ;
 159
 160 : (!field-doer)  ( value stx pfa -- value )
 161   a>r swap >a (!a-field-doer) r>a
 162 ;
 163
 164 ;; check if we aren't defining a struct
 165 : (?normal)  ( -- )
 166   compiler:?exec
 167   current @ (vocid-typeid@)  " already defining some data structure" ?error
 168 ;
 169
 170 ;; check if we are defining a struct
 171 : (?struct)  ( -- )
 172   compiler:?exec
 173   current @ (vocid-struct?) " not defining a struct" ?not-error
 174 ;
 175
 176
 177 ;; CURRENT must be the empty struct wordlist
 178 : (create-default-fields)  ( -- )
 179   ;; temporarily remove parent, to disable "word redefined" warnings
 180   current @ dup (vocid-parent@) >r >r  ( | parent vocid )
 181   0 r@ (vocid-parent!)
 182
 183   <public-words> \ <protected-words>
 184
 185   (sofs-size) ['] (@field-doer) " @size" (create-field)
 186   (sofs-parent) ['] (@field-doer) " @parent" (create-field)
 187   (sofs-self) ['] (@field-doer) " @self" (create-field)
 188
 189   ;; restore parent
 190   r> r> swap (vocid-parent!)
 191 ;
 192
 193 previous definitions
 194 also struct-internals
 195
 196
 197 ;; high-level API
 198 : define  ( -- )  \ name [ EXTENDS OtherStruct ]
 199   (?normal)
 200   parse-skip-line-comments parse-name dup " struct name expected" ?not-error
 201   (create-wlist)
 202   dup  >r nrot forth:(create-named-vocab)  ;; ( | vocid )
 203   ;; HACK! set DOER for non-CREATEd word
 204   ;; it works due to how doers are implemented in VM
 205   ['] (struct-doer) cfa->pfa latest-cfa compiler:(set-doer-no-checks)
 206   ;; define new words in this dictionary (because why not)
 207   current @ to (saved-current)
 208   also r> current ! vocid: struct context !
 209   (create-default-fields)
 210 ;
 211
 212 : extends  ( -- )  \ name
 213   (?struct)
 214   ;; we can extend only structs without parents, and
 215   ;; the struct cannot have any user fields defined yet
 216   current @  ( vocid )
 217   ;; check parent
 218   dup (vocid-parent@) " cannot extend already extended struct" ?error
 219   ;; check size
 220   dup (vocid-struct-size@) (sofs-internal-size) <> " cannot extend struct with defined fields" ?error
 221   ;; ok, we can do it, parse parent struct name
 222   parse-skip-line-comments -find-required  ( vocid cfa )
 223   ;; check if the given name is a struct
 224   dup (word-struct?) " vocabulary name expected" ?not-error
 225   (word->vocid)  ( vocid parent-vocid )
 226   ;; check type
 227   dup (vocid-struct?) " struct name expected" ?not-error
 228   ;; do not try to extend ourself
 229   2dup = " struct cannot extend itself" ?error
 230   ;; ok, we can set a parent
 231   2dup swap (vocid-parent!)   ( vocid parent-vocid )
 232   ;; we have to fix current struct size too
 233   (vocid-struct-size@)       ;; get parent struct size
 234   swap (vocid-struct-size!)  ;; and store it as our own
 235 ;
 236
 237 ;; define struct field
 238 : field:  ( -- )  \ name
 239   (?struct)
 240   ;; build it manually
 241   parse-skip-line-comments parse-name dup " field name expected" ?not-error
 242   current @ (vocid-struct-size@) dup >r  ;; current struct size is field offset
 243   ['] (@field-doer)    ;; doer ( addr count ofs doer-cfa | ofs )
 244   2over (create-field) ;; ( addr count | ofs )
 245   ;; save original char (it is safe to assume that we have one free byte in TIB)
 246   2dup + c@ >r rswap   ;; ( addr count | oldch ofs )
 247   ;; create "name!"
 248   2dup + [char] ! swap c!
 249   r> ['] (!field-doer) 2over 1+ (create-field)
 250   ;; restore original char
 251   + r> swap c!
 252   ;; now fix struct size
 253   cell current @ (sofs-vocid-size) + +!
 254 ;
 255
 256 ;; finish structure definition
 257 : end-struct  ( -- )  \ [structname]
 258   (?struct)
 259   parse-skip-line-comments parse-name dup if
 260     find-word " wut?" ?not-error
 261     dup (word-struct?) " invalid struct name" ?not-error
 262     (word->vocid) current @ <> " invalid struct name" ?error
 263   else 2drop endif
 264   previous
 265   (saved-current) current !
 266 ;
 267
 268 ;; for vocids
 269 : size-of  ( vocid -- size )
 270   dup (vocid-struct?) " struct vocid expected" ?not-error
 271   (vocid-struct-size@)
 272 ;
 273
 274 : parent-of  ( vocid -- parent-vocid / 0 )
 275   dup (vocid-struct?) " struct vocid expected" ?not-error
 276   (vocid-parent@)
 277 ;
 278
 279 ;; get name of the structure pointed to by the given vocid
 280 : name-of  ( vocid -- addr count )
 281   dup (vocid-struct?) " struct vocid expected" ?not-error
 282   compiler:(vocofs-header) + @
 283   ?dup if id-count else 0 0 endif
 284 ;
 285
 286 ;; for allocated structs
 287 : @size-of  ( stx -- size )
 288   dup (addr-struct?) " allocated struct expected" ?not-error
 289   a>r >a (sofs-size) @a+ r>a
 290 ;
 291
 292 : @parent-of  ( stx -- parent-vocid / 0 )
 293   dup (addr-struct?) " allocated struct expected" ?not-error
 294   a>r >a (sofs-parent) @a+ r>a
 295 ;
 296
 297 : @id-of  ( stx -- vocid )
 298   dup (addr-struct?) " allocated struct expected" ?not-error
 299   a>r >a (sofs-self) @a+ r>a
 300 ;
 301
 302 ;; get name of the structure pointed to by the given vocid
 303 : @name-of  ( vocid -- addr count )
 304   dup (addr-struct?) " allocated struct expected" ?not-error
 305   a>r >a (sofs-self) @a+ r>a
 306   dup (vocid-struct?) " struct vocid expected" ?not-error
 307   compiler:(vocofs-header) + @
 308   ?dup if id-count else 0 0 endif
 309 ;
 310
 311
 312 ;; allocate dynamic struct
 313 : new  ( vocid -- stx )
 314   (?normal)  ;; just in case
 315   dup (vocid-struct?) " struct expected" ?not-error  ( vocid )
 316   >r (wl-struct-typeid) handle:new  ( stx | vocid )
 317   ;; allocate memory
 318   r@ (vocid-struct-size@) over handle:size!
 319   ;; setup internal struct fields
 320   ;; size
 321   r@ (vocid-struct-size@) over (sofs-size) swap handle:!
 322   ;; parent
 323   r@ (vocid-parent@) over (sofs-parent) swap handle:!
 324   ;; self
 325   r> over (sofs-self) swap handle:!
 326 ;
 327
 328 ;; allocate dynamic struct
 329 : allot  ( vocid -- dict-addr )
 330   (?normal)  ;; just in case
 331   dup (vocid-struct?) " struct expected" ?not-error  ( vocid )
 332   ;; allocate memory
 333   dup >r (vocid-struct-size@) n-allot  ( addr | vocid )
 334   ;; setup internal struct fields
 335   ;; size
 336   r@ (vocid-struct-size@) over (sofs-size) + !
 337   ;; parent
 338   r@ (vocid-parent@) over (sofs-parent) + !
 339   ;; self
 340   r> over (sofs-self) + !
 341   ;; return address
 342 ;
 343
 344 alias-for vocid: is id:
 345
 346
 347 previous previous definitions