git.gag.com Git - debian/pforth/blob - 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, Devid 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 anew task-ansilocs.fth
  25
  26 private{
  27
  28 decimal
  29 16 constant LV_MAX_VARS    \ maximum number of local variables
  30 31 constant LV_MAX_CHARS   \ maximum number of letters in name
  31
  32 lv_max_vars lv_max_chars $array LV-NAMES
  33 variable LV-#NAMES   \ number of names currently defined
  34
  35 \ Search name table for match
  36 : LV.MATCH ( $string -- index true | $string false )
  37     0 swap
  38     lv-#names @ 0
  39     ?DO  i lv-names
  40         over $=
  41         IF  2drop true i LEAVE
  42         THEN
  43     LOOP swap
  44 ;
  45
  46 : LV.COMPILE.FETCH  ( index -- )
  47         1+  \ adjust for optimised (local@), LocalsPtr points above vars
  48         CASE
  49         1 OF compile (1_local@) ENDOF
  50         2 OF compile (2_local@) ENDOF
  51         3 OF compile (3_local@) ENDOF
  52         4 OF compile (4_local@) ENDOF
  53         5 OF compile (5_local@) ENDOF
  54         6 OF compile (6_local@) ENDOF
  55         7 OF compile (7_local@) ENDOF
  56         8 OF compile (8_local@) ENDOF
  57         dup [compile] literal compile (local@)
  58         ENDCASE
  59 ;
  60
  61 : LV.COMPILE.STORE  ( index -- )
  62         1+  \ adjust for optimised (local!), LocalsPtr points above vars
  63         CASE
  64         1 OF compile (1_local!) ENDOF
  65         2 OF compile (2_local!) ENDOF
  66         3 OF compile (3_local!) ENDOF
  67         4 OF compile (4_local!) ENDOF
  68         5 OF compile (5_local!) ENDOF
  69         6 OF compile (6_local!) ENDOF
  70         7 OF compile (7_local!) ENDOF
  71         8 OF compile (8_local!) ENDOF
  72         dup [compile] literal compile (local!)
  73         ENDCASE
  74 ;
  75
  76 : LV.COMPILE.LOCAL  ( $name -- handled? , check for matching locals name )
  77 \ ." LV.COMPILER.LOCAL name = " dup count type cr
  78         lv.match
  79         IF ( index )
  80                 lv.compile.fetch
  81                 true
  82         ELSE
  83                 drop false
  84         THEN
  85 ;
  86
  87 : LV.CLEANUP ( -- , restore stack frame on exit from colon def )
  88         lv-#names @
  89         IF
  90                 compile (local.exit)
  91         THEN
  92 ;
  93 : LV.FINISH ( -- , restore stack frame on exit from colon def )
  94         lv.cleanup
  95         lv-#names off
  96         local-compiler off
  97 ;
  98
  99 : LV.SETUP ( -- )
 100         0 lv-#names !
 101 ;
 102
 103 : LV.TERM
 104         ." Locals turned off" cr
 105         lv-#names off
 106         local-compiler off
 107 ;
 108
 109 if.forgotten lv.term
 110
 111 }private
 112
 113 : (LOCAL)  ( adr len -- , ANSI local primitive )
 114         dup
 115         IF
 116                 lv-#names @ lv_max_vars >= abort" Too many local variables!"
 117                 lv-#names @  lv-names place
 118 \ Warn programmer if local variable matches an existing dictionary name.
 119                 lv-#names @  lv-names find nip
 120                 IF
 121                         ." (LOCAL) - Note: "
 122                         lv-#names @  lv-names count type
 123                         ."  redefined as a local variable in "
 124                         latest id. cr
 125                 THEN
 126                 1 lv-#names +!
 127         ELSE
 128 \ Last local. Finish building local stack frame.
 129                 2drop
 130                 lv-#names @ [compile] literal   compile (local.entry)
 131                 ['] lv.compile.local local-compiler !
 132         THEN
 133 ;
 134
 135
 136 : VALUE
 137         CREATE ( n <name> )
 138                 ,
 139                 immediate
 140         DOES>
 141                 state @
 142                 IF
 143                         [compile] aliteral
 144                         compile @
 145                 ELSE
 146                         @
 147                 THEN
 148 ;
 149
 150 : TO  ( val <name> -- )
 151         bl word
 152         lv.match
 153         IF  ( -- index )
 154                 lv.compile.store
 155         ELSE
 156                 find
 157                 1 = 0= abort" TO or -> before non-local or non-value"
 158                 >body  \ point to data
 159                 state @
 160                 IF  \ compiling  ( -- pfa )
 161                         [compile] aliteral
 162                         compile !
 163                 ELSE \ executing  ( -- val pfa )
 164                         !
 165                 THEN
 166         THEN
 167 ; immediate
 168
 169 : ->  ( -- )  [compile] to  ; immediate
 170
 171 : +->  ( val <name> -- )
 172         bl word
 173         lv.match
 174         IF  ( -- index )
 175                 1+  \ adjust for optimised (local!), LocalsPtr points above vars
 176                 [compile] literal compile (local+!)
 177         ELSE
 178                 find
 179                 1 = 0= abort" +-> before non-local or non-value"
 180                 >body  \ point to data
 181                 state @
 182                 IF  \ compiling  ( -- pfa )
 183                         [compile] aliteral
 184                         compile +!
 185                 ELSE \ executing  ( -- val pfa )
 186                         +!
 187                 THEN
 188         THEN
 189 ; immediate
 190
 191 : :      lv.setup   : ;
 192 : ;      lv.finish  [compile] ;      ; immediate
 193 : exit   lv.cleanup  compile exit   ; immediate
 194 : does>  lv.finish  [compile] does>  ; immediate
 195
 196 privatize