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 \ Permission to use, copy, modify, and/or distribute this
  16 \ software for any purpose with or without fee is hereby granted.
  17 \
  18 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  19 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  20 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  21 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  22 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  23 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  24 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  25 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  26 \
  27 \ 10/27/99 Fixed  : foo { -- } 55 ; was entering local frame but not exiting.
  28
  29 anew task-ansilocs.fth
  30
  31 private{
  32
  33 decimal
  34 16 constant LV_MAX_VARS    \ maximum number of local variables
  35 31 constant LV_MAX_CHARS   \ maximum number of letters in name
  36
  37 lv_max_vars lv_max_chars $array LV-NAMES
  38 variable LV-#NAMES   \ number of names currently defined
  39
  40 \ Search name table for match
  41 : LV.MATCH ( $string -- index true | $string false )
  42     0 swap
  43     lv-#names @ 0
  44     ?DO  i lv-names
  45         over $=
  46         IF  2drop true i LEAVE
  47         THEN
  48     LOOP swap
  49 ;
  50
  51 : LV.COMPILE.FETCH  ( index -- )
  52     1+  \ adjust for optimised (local@), LocalsPtr points above vars
  53     CASE
  54     1 OF compile (1_local@) ENDOF
  55     2 OF compile (2_local@) ENDOF
  56     3 OF compile (3_local@) ENDOF
  57     4 OF compile (4_local@) ENDOF
  58     5 OF compile (5_local@) ENDOF
  59     6 OF compile (6_local@) ENDOF
  60     7 OF compile (7_local@) ENDOF
  61     8 OF compile (8_local@) ENDOF
  62     dup [compile] literal compile (local@)
  63     ENDCASE
  64 ;
  65
  66 : LV.COMPILE.STORE  ( index -- )
  67     1+  \ adjust for optimised (local!), LocalsPtr points above vars
  68     CASE
  69     1 OF compile (1_local!) ENDOF
  70     2 OF compile (2_local!) ENDOF
  71     3 OF compile (3_local!) ENDOF
  72     4 OF compile (4_local!) ENDOF
  73     5 OF compile (5_local!) ENDOF
  74     6 OF compile (6_local!) ENDOF
  75     7 OF compile (7_local!) ENDOF
  76     8 OF compile (8_local!) ENDOF
  77     dup [compile] literal compile (local!)
  78     ENDCASE
  79 ;
  80
  81 : LV.COMPILE.LOCAL  ( $name -- handled? , check for matching locals name )
  82 \ ." LV.COMPILER.LOCAL name = " dup count type cr
  83     lv.match
  84     IF ( index )
  85         lv.compile.fetch
  86         true
  87     ELSE
  88         drop false
  89     THEN
  90 ;
  91
  92 : LV.CLEANUP ( -- , restore stack frame on exit from colon def )
  93     lv-#names @
  94     IF
  95         compile (local.exit)
  96     THEN
  97 ;
  98 : LV.FINISH ( -- , restore stack frame on exit from colon def )
  99     lv.cleanup
 100     lv-#names off
 101     local-compiler off
 102 ;
 103
 104 : LV.SETUP ( -- )
 105     0 lv-#names !
 106 ;
 107
 108 : LV.TERM
 109     ." Locals turned off" cr
 110     lv-#names off
 111     local-compiler off
 112 ;
 113
 114 if.forgotten lv.term
 115
 116 }private
 117
 118 : (LOCAL)  ( adr len -- , ANSI local primitive )
 119     dup
 120     IF
 121         lv-#names @ lv_max_vars >= abort" Too many local variables!"
 122         lv-#names @  lv-names place
 123 \ Warn programmer if local variable matches an existing dictionary name.
 124         lv-#names @  lv-names find nip
 125         IF
 126             ." (LOCAL) - Note: "
 127             lv-#names @  lv-names count type
 128             ."  redefined as a local variable in "
 129             latest id. cr
 130         THEN
 131         1 lv-#names +!
 132     ELSE
 133 \ Last local. Finish building local stack frame.
 134         2drop
 135         lv-#names @ dup 0=  \ fixed 10/27/99, Thanks to John Providenza
 136         IF
 137             drop ." (LOCAL) - Warning: no locals defined!" cr
 138         ELSE
 139             [compile] literal   compile (local.entry)
 140             ['] lv.compile.local local-compiler !
 141         THEN
 142     THEN
 143 ;
 144
 145
 146 : VALUE
 147     CREATE ( n <name> )
 148         ,
 149         immediate
 150     DOES>
 151         state @
 152         IF
 153             [compile] aliteral
 154             compile @
 155         ELSE
 156             @
 157         THEN
 158 ;
 159
 160 : TO  ( val <name> -- )
 161     bl word
 162     lv.match
 163     IF  ( -- index )
 164         lv.compile.store
 165     ELSE
 166         find
 167         1 = 0= abort" TO or -> before non-local or non-value"
 168         >body  \ point to data
 169         state @
 170         IF  \ compiling  ( -- pfa )
 171             [compile] aliteral
 172             compile !
 173         ELSE \ executing  ( -- val pfa )
 174             !
 175         THEN
 176     THEN
 177 ; immediate
 178
 179 : ->  ( -- )  [compile] to  ; immediate
 180
 181 : +->  ( val <name> -- )
 182     bl word
 183     lv.match
 184     IF  ( -- index )
 185         1+  \ adjust for optimised (local!), LocalsPtr points above vars
 186         [compile] literal compile (local+!)
 187     ELSE
 188         find
 189         1 = 0= abort" +-> before non-local or non-value"
 190         >body  \ point to data
 191         state @
 192         IF  \ compiling  ( -- pfa )
 193             [compile] aliteral
 194             compile +!
 195         ELSE \ executing  ( -- val pfa )
 196             +!
 197         THEN
 198     THEN
 199 ; immediate
 200
 201 : :      lv.setup   : ;
 202 : ;      lv.finish  [compile] ;      ; immediate
 203 : exit   lv.cleanup  compile exit   ; immediate
 204 : does>  lv.finish  [compile] does>  ; immediate
 205
 206 privatize