urflibs/stdlib/70-pseudostructs-obsolete.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 ;; pseudostructs
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10
  11 simple-vocabulary (pseudostructs-internal)
  12 also-defs: (pseudostructs-internal)
  13
  14 ;; create "record->name"
  15 : (create-ofs-accessor)  ( ofs-in-bytes addr count -- ofs-acc-cfa )
  16   (create) latest-cfa swap
  17   , does> ( info-addr pfa -- info-addr-with-offset ) @ +
  18 ;
  19
  20 ;; create "class->nameX"
  21 : (create-accessor)  ( addr count ofs-acc-cfa cfa-r/w char -- )
  22   >r 2swap string:>pad r> string:pad+char
  23   string:pad-cc@ compiler:(create-forth-header)
  24   swap compile, compile, compile forth:(exit) compiler:smudge
  25 ;
  26
  27 : (create-peek-accessor)  ( addr count ofs-acc-cfa -- )  ['] @ [char] @ (create-accessor) ;
  28 : (create-poke-accessor)  ( addr count ofs-acc-cfa -- )  ['] ! [char] ! (create-accessor) ;
  29
  30 prev-defs
  31
  32 (*
  33 usage:
  34   0
  35   new-accessors rec->field0
  36   new-accessors rec->field1
  37   constant rec-size
  38
  39 now, "rec-size" is record size in bytes. each field is a cell, and
  40 have "rec->field" (offset), "rec->field@" and "rec->field!" accessors.
  41
  42 *)
  43 ;; create accessors
  44 ;; trashes PAD
  45 : new-accessors  ( ofs -- ofs+4 )  \ name
  46   parse-name 2>r  ( ofs | addr count )
  47   dup 2r@ (pseudostructs-internal):(create-ofs-accessor)  ( ofs ofs-acc-cfa | addr count )
  48   dup 2r@ rot (pseudostructs-internal):(create-peek-accessor)
  49       2r> rot (pseudostructs-internal):(create-poke-accessor)
  50   cell+
  51 ;