urflibs/locals.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 ;; local variables support
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (*
  11   : myword  ( a b -- c )
  12     args: a b
  13     locals: loc1 loc2
  14
  15     :a TO :loc1
  16     :b TO :loc2
  17     :loc1 :loc2 +
  18   ;
  19 here, "args:" will declare local variables, and automatically fill them
  20 with arguments from the data stack. "locals:" declare "free" locals.
  21 there can be more than one "locals:" section, but all such sections should
  22 come before anything else. to use local, you must prepend its name with a
  23 colon. the usual "TO" word is used to set local values.
  24 *)
  25
  26 vocabulary (locals-support)
  27 also (locals-support) definitions
  28
  29 ;; offset in temp (user) dict
  30 ;; should be enough for now ;-)
  31 \ 65536 constant locals-temp-voc-offset
  32
  33 0 value locals-dp-temp-saved
  34 0 value locals-vocid
  35
  36 : new-locals-wordlist  ( -- )
  37   forth:(dp-here) @ dup forth:(dp-main) <> " invalid (DP-HERE)" ?error
  38   forth:(dp-temp) dup @ to locals-dp-temp-saved forth:(dp-here) !
  39   0 false forth:(new-wordlist) to locals-vocid
  40   forth:(dp-here) !
  41 ;
  42
  43 ;; (L-ENTER) arg:
  44 ;; low byte of loccount is total number of locals
  45 ;; high byte is the number of args
  46
  47 : latest-has-locals?  ( -- bool )
  48   latest-pfa dup here = if drop false
  49   else @ ['] forth:(l-enter) = endif
  50 ;
  51
  52 : start-locals  ( -- )
  53   latest-pfa here <> if
  54     latest-has-locals? " \`locals:\` or \`args:\` should be the first word" ?not-error
  55   else  ;; init locals
  56     new-locals-wordlist compile forth:(l-enter) 0 ,
  57   endif
  58 ;
  59
  60 : add-local  ( addr count -- )
  61   start-locals
  62   latest-pfa cell+  dup c@ 255 = " too many locals" ?error
  63   1 over +! c@ >r  ;; save current local number to rstack
  64   ;; now create access word
  65   forth:(dp-here) @  current @
  66   forth:(dp-temp) forth:(dp-here) !  locals-vocid current !
  67   \ ." DP: " forth:(dp) @ . cr
  68   \ ." DP-TEMP: " forth:(dp-temp) @ . cr
  69   \ ." HERE: " here . cr
  70   2swap
  71   \ 2dup xtype cr
  72   compiler:(create-header)
  73   compiler:(cfaidx-do-const) compiler:cfa,  ;; why not
  74   r> ,  ;; local index
  75   compiler:reset-smudge
  76   forth:(dp-temp) @ here <> " wtf?!" ?error  ;; assertion
  77   ;; restore voc and DP
  78   current !  forth:(dp-here) !
  79 ;
  80
  81 ;; create local access words, adjust "(L-ENTER)"
  82 : add-arg  ( addr count -- )
  83   add-local 0x01_00 latest-pfa cell+ +!
  84 ;
  85
  86 : parse-loc-list  ( regcfa -- )
  87   >r begin
  88     parse-skip-line-comments
  89     parse-name ?dup
  90   while r@ execute repeat
  91   drop rdrop
  92 ;
  93
  94
  95 ..: forth:(exit-extender)  ( -- )
  96   latest-has-locals? if
  97     compile forth:(l-leave)
  98     locals-dp-temp-saved forth:(dp-temp) !
  99   endif
 100 ;..
 101
 102
 103 : find-local  ( addr count -- addr count FALSE / idx TRUE )
 104   false >r
 105   2dup  1 >  swap c@ [char] : =  and if
 106     latest-has-locals? if  ( addr count | ret-flag )
 107       over 1+ over 1- locals-vocid find-word-in-voc
 108       if  ;; i found her!
 109         >r 2drop r> cfa->pfa @
 110         rdrop true >r
 111       endif
 112     endif
 113   endif
 114   r>
 115 ;
 116
 117 ..: forth:(to-extender)  ( addr count FALSE -- addr count FALSE / TRUE )
 118   dup ifnot
 119     compiler:comp? if drop
 120       find-local if literal compile forth:(local!) true
 121       else false
 122       endif
 123     endif
 124   endif
 125 ;..
 126
 127
 128 ..: forth:(interpret-check-word)  ( addr count FALSE -- addr count FALSE / TRUE )
 129   dup ifnot
 130     compiler:comp? if drop
 131       find-local if literal compile forth:(local@) true
 132       else false
 133       endif
 134     endif
 135   endif
 136 ;..
 137
 138
 139 previous definitions
 140
 141
 142 : args:    ['] (locals-support):add-arg (locals-support):parse-loc-list ; immediate
 143 : locals:  ['] (locals-support):add-local (locals-support):parse-loc-list ; immediate