git.gag.com Git - debian/pforth/blob - fth/ansilocs.fth

   1 \ @(#) ansilocs.fth 98/01/26 1.3
   2 \ local variable support words
   3 \ These support the ANSI standard (LOCAL) and TO words.
   4 \
   5 \ They are built from the following low level primitives written in 'C':
   6 \    (local@) ( i+1 -- n , fetch from ith local variable )
   7 \    (local!) ( n i+1 -- , store to ith local variable )
   8 \    (local.entry) ( num -- , allocate stack frame for num local variables )
   9 \    (local.exit)  ( -- , free local variable stack frame )
  10 \    local-compiler ( -- addr , variable containing CFA of locals compiler )
  11 \
  12 \ Author: Phil Burk
  13 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  14 \
  15 \ The pForth software code is dedicated to the public domain,
  16 \ and any third party may reproduce, distribute and modify
  17 \ the pForth software code or any derivative works thereof
  18 \ without any compensation or license.  The pForth software
  19 \ code is provided on an "as is" basis without any warranty
  20 \ of any kind, including, without limitation, the implied
  21 \ warranties of merchantability and fitness for a particular
  22 \ purpose and their equivalents under the laws of any jurisdiction.
  23 \
  24 \ 10/27/99 Fixed  : foo { -- } 55 ; was entering local frame but not exiting.
  25
  26 anew task-ansilocs.fth
  27
  28 private{
  29
  30 decimal
  31 16 constant LV_MAX_VARS    \ maximum number of local variables
  32 31 constant LV_MAX_CHARS   \ maximum number of letters in name
  33
  34 lv_max_vars lv_max_chars $array LV-NAMES
  35 variable LV-#NAMES   \ number of names currently defined
  36
  37 \ Search name table for match
  38 : LV.MATCH ( $string -- index true | $string false )
  39     0 swap
  40     lv-#names @ 0
  41     ?DO  i lv-names
  42         over $=
  43         IF  2drop true i LEAVE
  44         THEN
  45     LOOP swap
  46 ;
  47
  48 : LV.COMPILE.FETCH  ( index -- )
  49     1+  \ adjust for optimised (local@), LocalsPtr points above vars
  50     CASE
  51     1 OF compile (1_local@) ENDOF
  52     2 OF compile (2_local@) ENDOF
  53     3 OF compile (3_local@) ENDOF
  54     4 OF compile (4_local@) ENDOF
  55     5 OF compile (5_local@) ENDOF
  56     6 OF compile (6_local@) ENDOF
  57     7 OF compile (7_local@) ENDOF
  58     8 OF compile (8_local@) ENDOF
  59     dup [compile] literal compile (local@)
  60     ENDCASE
  61 ;
  62
  63 : LV.COMPILE.STORE  ( index -- )
  64     1+  \ adjust for optimised (local!), LocalsPtr points above vars
  65     CASE
  66     1 OF compile (1_local!) ENDOF
  67     2 OF compile (2_local!) ENDOF
  68     3 OF compile (3_local!) ENDOF
  69     4 OF compile (4_local!) ENDOF
  70     5 OF compile (5_local!) ENDOF
  71     6 OF compile (6_local!) ENDOF
  72     7 OF compile (7_local!) ENDOF
  73     8 OF compile (8_local!) ENDOF
  74     dup [compile] literal compile (local!)
  75     ENDCASE
  76 ;
  77
  78 : LV.COMPILE.LOCAL  ( $name -- handled? , check for matching locals name )
  79 \ ." LV.COMPILER.LOCAL name = " dup count type cr
  80     lv.match
  81     IF ( index )
  82         lv.compile.fetch
  83         true
  84     ELSE
  85         drop false
  86     THEN
  87 ;
  88
  89 : LV.CLEANUP ( -- , restore stack frame on exit from colon def )
  90     lv-#names @
  91     IF
  92         compile (local.exit)
  93     THEN
  94 ;
  95 : LV.FINISH ( -- , restore stack frame on exit from colon def )
  96     lv.cleanup
  97     lv-#names off
  98     local-compiler off
  99 ;
 100
 101 : LV.SETUP ( -- )
 102     0 lv-#names !
 103 ;
 104
 105 : LV.TERM
 106     ." Locals turned off" cr
 107     lv-#names off
 108     local-compiler off
 109 ;
 110
 111 if.forgotten lv.term
 112
 113 }private
 114
 115 : (LOCAL)  ( adr len -- , ANSI local primitive )
 116     dup
 117     IF
 118         lv-#names @ lv_max_vars >= abort" Too many local variables!"
 119         lv-#names @  lv-names place
 120 \ Warn programmer if local variable matches an existing dictionary name.
 121         lv-#names @  lv-names find nip
 122         IF
 123             ." (LOCAL) - Note: "
 124             lv-#names @  lv-names count type
 125             ."  redefined as a local variable in "
 126             latest id. cr
 127         THEN
 128         1 lv-#names +!
 129     ELSE
 130 \ Last local. Finish building local stack frame.
 131         2drop
 132         lv-#names @ dup 0=  \ fixed 10/27/99, Thanks to John Providenza
 133         IF
 134             drop ." (LOCAL) - Warning: no locals defined!" cr
 135         ELSE
 136             [compile] literal   compile (local.entry)
 137             ['] lv.compile.local local-compiler !
 138         THEN
 139     THEN
 140 ;
 141
 142
 143 : VALUE
 144     CREATE ( n <name> )
 145         ,
 146         immediate
 147     DOES>
 148         state @
 149         IF
 150             [compile] aliteral
 151             compile @
 152         ELSE
 153             @
 154         THEN
 155 ;
 156
 157 : TO  ( val <name> -- )
 158     bl word
 159     lv.match
 160     IF  ( -- index )
 161         lv.compile.store
 162     ELSE
 163         find
 164         1 = 0= abort" TO or -> before non-local or non-value"
 165         >body  \ point to data
 166         state @
 167         IF  \ compiling  ( -- pfa )
 168             [compile] aliteral
 169             compile !
 170         ELSE \ executing  ( -- val pfa )
 171             !
 172         THEN
 173     THEN
 174 ; immediate
 175
 176 : ->  ( -- )  [compile] to  ; immediate
 177
 178 : +->  ( val <name> -- )
 179     bl word
 180     lv.match
 181     IF  ( -- index )
 182         1+  \ adjust for optimised (local!), LocalsPtr points above vars
 183         [compile] literal compile (local+!)
 184     ELSE
 185         find
 186         1 = 0= abort" +-> before non-local or non-value"
 187         >body  \ point to data
 188         state @
 189         IF  \ compiling  ( -- pfa )
 190             [compile] aliteral
 191             compile +!
 192         ELSE \ executing  ( -- val pfa )
 193             +!
 194         THEN
 195     THEN
 196 ; immediate
 197
 198 : :      lv.setup   : ;
 199 : ;      lv.finish  [compile] ;      ; immediate
 200 : exit   lv.cleanup  compile exit   ; immediate
 201 : does>  lv.finish  [compile] does>  ; immediate
 202
 203 privatize