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

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