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 literal compile +
  37     else + endif
  38   endif
  39 ;
  40
  41 ;; create "record->nameX"
  42 : (create-accessor)  ( addr count ofs do-write? char -- )
  43   pad @ >r " ->" string:pad+cc >r 2swap string:pad+cc r> string:pad+char
  44   string:pad-cc@ (create)
  45   ;; pfa: ofs cfa-r/w-compile ofs cfa-r/w-exec
  46   if , ['] forth:(direct:+:!) , ['] forth:! ,
  47   else , ['] forth:(direct:+:@) , ['] forth:@ ,
  48   endif
  49   r> pad !
  50   immediate
  51  does> ( base pfa )
  52   compiler:comp? if
  53     dup @ ?dup if swap cell+ @ compile-start, compile-end,
  54     else 2 +cells @ compile, endif
  55   else dup @ rot + swap 2 +cells @execute-tail
  56   endif
  57 ;
  58
  59 : (create-peek-accessor)  ( addr count ofs -- )  false [char] @ (create-accessor) ;
  60 : (create-poke-accessor)  ( addr count ofs -- )  true [char] ! (create-accessor) ;
  61
  62 prev-defs
  63
  64
  65 simple-vocabulary (struct-accs-defs)
  66 also-defs: (struct-accs-defs)
  67
  68 : def:  ( ofs -- ofs+4 )  \ name
  69   >r  ;; save offset
  70   parse-name dup " accessor name expected" ?not-error
  71   2dup r@ (struct-accs-internal):(create-ofs-accessor) >r
  72   2dup r@ (struct-accs-internal):(create-peek-accessor)
  73   r> (struct-accs-internal):(create-poke-accessor)
  74   r> cell+
  75 ;
  76
  77 : end-accessors  ( ofs -- )
  78   previous
  79   ;; create constant
  80   " -size" string:pad+cc
  81   string:pad-cc@ compiler:(create-header)
  82   compiler:(cfaidx-do-const) compiler:cfa, ,
  83   compiler:smudge
  84 ;
  85
  86 prev-defs
  87
  88
  89 ;; create accessors
  90 ;; trashes PAD
  91 : define-accessors  ( -- 0 )  \ name
  92   parse-name string:>pad
  93   0 also (struct-accs-defs)
  94 ;
  95
  96 (*
  97 define-accessors boo
  98   def: first
  99   def: second
 100 end-accessors
 101
 102 boo-size . cr
 103 debug:decompile boo->second!
 104 *)