urflibs/stdlib/70-pseudostructs.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 (*
  12 usage:
  13   define-accessors rec
  14     acc: field0
  15     acc: field1
  16   end-accessors  -- defines constant "rec-size"
  17
  18 now, "rec-size" is record size in bytes. each field is a cell, and
  19 have "rec->field" (offset), "rec->field@" and "rec->field!" accessors.
  20 *)
  21
  22
  23 simple-vocabulary (struct-accs-internal)
  24 also-defs: (struct-accs-internal)
  25
  26 ;; create "record->name"
  27 : (create-ofs-accessor)  ( addr count ofs-in-bytes -- ofs-in-bytes )
  28   dup >r
  29   pad @ >r nrot " ->" string:pad+cc string:pad+cc
  30   string:pad-cc@ (create) ,
  31   r> pad ! r>
  32   immediate
  33  does> ( info-addr pfa -- info-addr-with-offset )
  34   @  ;; offset
  35   ?dup if
  36     compiler:comp? if
  37       here >r literal r> compiler:(after-compile-lit)
  38       here >r compile + r> compiler:(after-compile-word)
  39     else + endif
  40   endif
  41 ;
  42
  43 ;; create "record->nameX"
  44 : (create-accessor)  ( addr count ofs do-write? char -- )
  45   pad @ >r " ->" string:pad+cc >r 2swap string:pad+cc r> string:pad+char
  46   string:pad-cc@ (create)
  47   ;; pfa: ofs cfa-r/w-compile ofs cfa-r/w-exec
  48   if , ['] forth:(direct:+:!) , ['] forth:! ,
  49   else , ['] forth:(direct:+:@) , ['] forth:@ ,
  50   endif
  51   r> pad !
  52   immediate
  53  does> ( base pfa )
  54   compiler:comp? if
  55     dup @ ?dup if swap cell+ @ here >r compile, , r> compiler:(after-compile-word)
  56     else 2 +cells @ here >r compile, r> compiler:(after-compile-word) endif
  57   else dup @ rot + swap 2 +cells @execute-tail
  58   endif
  59 ;
  60
  61 : (create-peek-accessor)  ( addr count ofs -- )  false [char] @ (create-accessor) ;
  62 : (create-poke-accessor)  ( addr count ofs -- )  true [char] ! (create-accessor) ;
  63
  64 prev-defs
  65
  66
  67 simple-vocabulary (struct-accs-defs)
  68 also-defs: (struct-accs-defs)
  69
  70 : def:  ( ofs -- ofs+4 )  \ name
  71   >r  ;; save offset
  72   parse-name dup " accessor name expected" ?not-error
  73   2dup r@ (struct-accs-internal):(create-ofs-accessor) >r
  74   2dup r@ (struct-accs-internal):(create-peek-accessor)
  75   r> (struct-accs-internal):(create-poke-accessor)
  76   r> cell+
  77 ;
  78
  79 : end-accessors  ( ofs -- )
  80   previous
  81   ;; create constant
  82   " -size" string:pad+cc
  83   string:pad-cc@ compiler:(create-header)
  84   compiler:(cfaidx-do-const) compiler:cfa, ,
  85   compiler:smudge
  86 ;
  87
  88 prev-defs
  89
  90
  91 ;; create accessors
  92 ;; trashes PAD
  93 : define-accessors  ( -- 0 )  \ name
  94   parse-name string:>pad
  95   0 also (struct-accs-defs)
  96 ;
  97
  98 (*
  99 define-accessors boo
 100   def: first
 101   def: second
 102 end-accessors
 103
 104 boo-size . cr
 105 debug:decompile boo->second!
 106 *)