qemu/roms/openbios/forth/lib/locals.fs

   1 \ tag: local variables
   2 \
   3 \ Copyright (C) 2012 Mark Cave-Ayland
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9 [IFDEF] CONFIG_LOCALS
  10
  11 \ Init local variable stack
  12 variable locals-var-stack
  13 here 200 cells allot locals-var-stack !
  14
  15 \ Set initial stack pointer
  16 \
  17 \ Stack looks like this:
  18 \ ... (sp n-2) local1 ... localm-1 localm (sp n-1)  <-- sp
  19
  20 locals-var-stack @ value locals-var-sp
  21 locals-var-sp locals-var-stack @ !
  22
  23 0 value locals-var-count
  24 0 value locals-flags
  25
  26 here 200 cells allot locals-dict-buf !
  27
  28 8 constant #locals
  29
  30 : (local1) locals-var-sp @ /n + ;
  31 : (local2) locals-var-sp @ 2 cells + ;
  32 : (local3) locals-var-sp @ 3 cells + ;
  33 : (local4) locals-var-sp @ 4 cells + ;
  34 : (local5) locals-var-sp @ 5 cells + ;
  35 : (local6) locals-var-sp @ 6 cells + ;
  36 : (local7) locals-var-sp @ 7 cells + ;
  37 : (local8) locals-var-sp @ 8 cells + ;
  38
  39 : local1@ (local1) @ ;
  40 : local2@ (local2) @ ;
  41 : local3@ (local3) @ ;
  42 : local4@ (local4) @ ;
  43 : local5@ (local5) @ ;
  44 : local6@ (local6) @ ;
  45 : local7@ (local7) @ ;
  46 : local8@ (local8) @ ;
  47
  48 : local1! (local1) ! ;
  49 : local2! (local2) ! ;
  50 : local3! (local3) ! ;
  51 : local4! (local4) ! ;
  52 : local5! (local5) ! ;
  53 : local6! (local6) ! ;
  54 : local7! (local7) ! ;
  55 : local8! (local8) ! ;
  56
  57 create locals-read-table
  58 ['] local1@ ,
  59 ['] local2@ ,
  60 ['] local3@ ,
  61 ['] local4@ ,
  62 ['] local5@ ,
  63 ['] local6@ ,
  64 ['] local7@ ,
  65 ['] local8@ ,
  66
  67 create locals-write-table
  68 ['] local1! ,
  69 ['] local2! ,
  70 ['] local3! ,
  71 ['] local4! ,
  72 ['] local5! ,
  73 ['] local6! ,
  74 ['] local7! ,
  75 ['] local8! ,
  76
  77
  78 : locals-push ( n -- )
  79   locals-var-sp /n + to locals-var-sp
  80   locals-var-sp !
  81 ;
  82
  83 : locals-0-push ( -- )
  84   0 locals-push
  85 ;
  86
  87 : (apply-local-flags) ( lfa -- )
  88   1 - dup c@ locals-flags or swap c!
  89 ;
  90
  91 : locals-no-pop? ( lfa -- ? )
  92   1 - c@ 8 and 0<>
  93 ;
  94
  95 : locals-drop      \ Destroy current stack frame
  96   locals-var-sp @ to locals-var-sp
  97 ;
  98
  99 ['] locals-drop to locals-end
 100
 101 : (local-init) ( str len -- )
 102   header 1 ,             \ DOCOL
 103   ['] (lit) , ['] noop , \ read-xt
 104   ['] (lit) , ['] noop , \ write-xt
 105   ['] 2drop ,            \ do nothing
 106   ['] (lit) ,
 107   here 5 cells - ,
 108   ['] @ , ['] , ,   \ store read-xt
 109   ['] (semis) ,
 110   reveal
 111   immediate
 112   last @ (apply-local-flags)
 113 ;
 114
 115 : (local-noop) ( str len -- )
 116   2drop
 117 ;
 118
 119 \ Word called when consuming a local variable
 120 defer (local)
 121
 122 : } ( C: current latest here -- )
 123   here! latest ! current !           \ Switch back to normal dict
 124   locals-dict-buf @ to locals-dict   \ Make locals-dict visible to $find
 125   0 to locals-var-count
 126   ['] locals-var-sp ,    \ save previous sp on rstack
 127   ['] >r ,
 128   locals-dict @    \ ( last -- )
 129   begin
 130     ?dup 0<>
 131   while
 132     >r
 133     locals-var-count /n *
 134     locals-read-table + @ r@ 3 cells + !    \ set read-xt
 135     locals-var-count /n *
 136     locals-write-table + @ r@ 5 cells + !   \ set write-xt
 137     locals-var-count 1+ to locals-var-count
 138     r@ locals-no-pop? if
 139       ['] locals-0-push ,    \ initialise with 0
 140     else
 141       ['] locals-push ,      \ initialise from stack
 142     then
 143     r> @  \ next lfa
 144   repeat
 145   ['] r> ,
 146   ['] locals-push ,   \ write previous sp
 147 ; immediate
 148
 149 : { ( C: -- current latest here )
 150   current @ latest @ here
 151   ['] (local-init) to (local)
 152   0 to locals-flags
 153   0 to locals-var-count
 154   locals-dict-buf @ 200 cells 0 fill    \ Zero out temporary dictionary
 155   locals-dict-buf @ current !     \ Switch to locals dictionary
 156   locals-dict-buf @ /n + here!
 157
 158   begin
 159     parse-word
 160     2dup s" }" strcmp 0= if
 161       2drop
 162       ['] } execute -1
 163     else
 164       2dup s" ;" strcmp 0= if
 165         2drop
 166         8 to locals-flags 0  \ Don't init from stack
 167       else
 168         2dup s" |" strcmp 0= if
 169           2drop
 170           8 to locals-flags 0   \ Don't init from stack
 171         else
 172           2dup s" --" strcmp 0= if
 173             2drop
 174             ['] (local-noop) to (local) 0
 175           else
 176             locals-var-count #locals < if
 177               (local) 0    \ accept local
 178             else
 179               s" maximum locals used ignoring " type type cr 0
 180             then
 181             locals-var-count 1+ to locals-var-count
 182           then
 183         then
 184       then
 185     then
 186   until
 187 ; immediate
 188
 189 : -> ( n -- )
 190   parse-word $find if
 191     4 cells + @ ,
 192   else
 193     s" unable to find word " type type
 194   then
 195 ; immediate
 196
 197 [THEN]