-\ @(#) ansilocs.fth 98/01/26 1.3\r
-\ local variable support words\r
-\ These support the ANSI standard (LOCAL) and TO words.\r
-\\r
-\ They are built from the following low level primitives written in 'C':\r
-\ (local@) ( i+1 -- n , fetch from ith local variable )\r
-\ (local!) ( n i+1 -- , store to ith local variable )\r
-\ (local.entry) ( num -- , allocate stack frame for num local variables )\r
-\ (local.exit) ( -- , free local variable stack frame )\r
-\ local-compiler ( -- addr , variable containing CFA of locals compiler )\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license. The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 10/27/99 Fixed : foo { -- } 55 ; was entering local frame but not exiting.\r
-\r
-anew task-ansilocs.fth\r
-\r
-private{\r
-\r
-decimal\r
-16 constant LV_MAX_VARS \ maximum number of local variables\r
-31 constant LV_MAX_CHARS \ maximum number of letters in name\r
-\r
-lv_max_vars lv_max_chars $array LV-NAMES\r
-variable LV-#NAMES \ number of names currently defined\r
-\r
-\ Search name table for match\r
-: LV.MATCH ( $string -- index true | $string false )\r
- 0 swap\r
- lv-#names @ 0\r
- ?DO i lv-names\r
- over $=\r
- IF 2drop true i LEAVE\r
- THEN\r
- LOOP swap\r
-;\r
-\r
-: LV.COMPILE.FETCH ( index -- )\r
- 1+ \ adjust for optimised (local@), LocalsPtr points above vars\r
- CASE\r
- 1 OF compile (1_local@) ENDOF\r
- 2 OF compile (2_local@) ENDOF\r
- 3 OF compile (3_local@) ENDOF\r
- 4 OF compile (4_local@) ENDOF\r
- 5 OF compile (5_local@) ENDOF\r
- 6 OF compile (6_local@) ENDOF\r
- 7 OF compile (7_local@) ENDOF\r
- 8 OF compile (8_local@) ENDOF\r
- dup [compile] literal compile (local@)\r
- ENDCASE\r
-;\r
-\r
-: LV.COMPILE.STORE ( index -- )\r
- 1+ \ adjust for optimised (local!), LocalsPtr points above vars\r
- CASE\r
- 1 OF compile (1_local!) ENDOF\r
- 2 OF compile (2_local!) ENDOF\r
- 3 OF compile (3_local!) ENDOF\r
- 4 OF compile (4_local!) ENDOF\r
- 5 OF compile (5_local!) ENDOF\r
- 6 OF compile (6_local!) ENDOF\r
- 7 OF compile (7_local!) ENDOF\r
- 8 OF compile (8_local!) ENDOF\r
- dup [compile] literal compile (local!)\r
- ENDCASE\r
-;\r
-\r
-: LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name )\r
-\ ." LV.COMPILER.LOCAL name = " dup count type cr\r
- lv.match\r
- IF ( index )\r
- lv.compile.fetch\r
- true\r
- ELSE\r
- drop false\r
- THEN\r
-;\r
-\r
-: LV.CLEANUP ( -- , restore stack frame on exit from colon def )\r
- lv-#names @\r
- IF\r
- compile (local.exit)\r
- THEN\r
-;\r
-: LV.FINISH ( -- , restore stack frame on exit from colon def )\r
- lv.cleanup\r
- lv-#names off\r
- local-compiler off\r
-;\r
-\r
-: LV.SETUP ( -- )\r
- 0 lv-#names !\r
-;\r
-\r
-: LV.TERM\r
- ." Locals turned off" cr\r
- lv-#names off\r
- local-compiler off\r
-;\r
-\r
-if.forgotten lv.term\r
-\r
-}private\r
-\r
-: (LOCAL) ( adr len -- , ANSI local primitive )\r
- dup\r
- IF\r
- lv-#names @ lv_max_vars >= abort" Too many local variables!"\r
- lv-#names @ lv-names place\r
-\ Warn programmer if local variable matches an existing dictionary name.\r
- lv-#names @ lv-names find nip\r
- IF\r
- ." (LOCAL) - Note: "\r
- lv-#names @ lv-names count type\r
- ." redefined as a local variable in "\r
- latest id. cr\r
- THEN\r
- 1 lv-#names +!\r
- ELSE\r
-\ Last local. Finish building local stack frame.\r
- 2drop\r
- lv-#names @ dup 0= \ fixed 10/27/99, Thanks to John Providenza\r
- IF\r
- drop ." (LOCAL) - Warning: no locals defined!" cr\r
- ELSE\r
- [compile] literal compile (local.entry)\r
- ['] lv.compile.local local-compiler !\r
- THEN\r
- THEN\r
-;\r
-\r
-\r
-: VALUE\r
- CREATE ( n <name> )\r
- ,\r
- immediate\r
- DOES>\r
- state @\r
- IF\r
- [compile] aliteral\r
- compile @\r
- ELSE\r
- @\r
- THEN\r
-;\r
-\r
-: TO ( val <name> -- )\r
- bl word\r
- lv.match\r
- IF ( -- index )\r
- lv.compile.store\r
- ELSE\r
- find \r
- 1 = 0= abort" TO or -> before non-local or non-value"\r
- >body \ point to data\r
- state @\r
- IF \ compiling ( -- pfa )\r
- [compile] aliteral\r
- compile !\r
- ELSE \ executing ( -- val pfa )\r
- !\r
- THEN\r
- THEN\r
-; immediate\r
-\r
-: -> ( -- ) [compile] to ; immediate\r
-\r
-: +-> ( val <name> -- )\r
- bl word\r
- lv.match\r
- IF ( -- index )\r
- 1+ \ adjust for optimised (local!), LocalsPtr points above vars\r
- [compile] literal compile (local+!)\r
- ELSE\r
- find \r
- 1 = 0= abort" +-> before non-local or non-value"\r
- >body \ point to data\r
- state @\r
- IF \ compiling ( -- pfa )\r
- [compile] aliteral\r
- compile +!\r
- ELSE \ executing ( -- val pfa )\r
- +!\r
- THEN\r
- THEN\r
-; immediate\r
-\r
-: : lv.setup : ;\r
-: ; lv.finish [compile] ; ; immediate\r
-: exit lv.cleanup compile exit ; immediate\r
-: does> lv.finish [compile] does> ; immediate\r
-\r
-privatize\r
+\ @(#) ansilocs.fth 98/01/26 1.3
+\ local variable support words
+\ These support the ANSI standard (LOCAL) and TO words.
+\
+\ They are built from the following low level primitives written in 'C':
+\ (local@) ( i+1 -- n , fetch from ith local variable )
+\ (local!) ( n i+1 -- , store to ith local variable )
+\ (local.entry) ( num -- , allocate stack frame for num local variables )
+\ (local.exit) ( -- , free local variable stack frame )
+\ local-compiler ( -- addr , variable containing CFA of locals compiler )
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+\
+\ Permission to use, copy, modify, and/or distribute this
+\ software for any purpose with or without fee is hereby granted.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+\
+\ 10/27/99 Fixed : foo { -- } 55 ; was entering local frame but not exiting.
+
+anew task-ansilocs.fth
+
+private{
+
+decimal
+16 constant LV_MAX_VARS \ maximum number of local variables
+31 constant LV_MAX_CHARS \ maximum number of letters in name
+
+lv_max_vars lv_max_chars $array LV-NAMES
+variable LV-#NAMES \ number of names currently defined
+
+\ Search name table for match
+: LV.MATCH ( $string -- index true | $string false )
+ 0 swap
+ lv-#names @ 0
+ ?DO i lv-names
+ over $=
+ IF 2drop true i LEAVE
+ THEN
+ LOOP swap
+;
+
+: LV.COMPILE.FETCH ( index -- )
+ 1+ \ adjust for optimised (local@), LocalsPtr points above vars
+ CASE
+ 1 OF compile (1_local@) ENDOF
+ 2 OF compile (2_local@) ENDOF
+ 3 OF compile (3_local@) ENDOF
+ 4 OF compile (4_local@) ENDOF
+ 5 OF compile (5_local@) ENDOF
+ 6 OF compile (6_local@) ENDOF
+ 7 OF compile (7_local@) ENDOF
+ 8 OF compile (8_local@) ENDOF
+ dup [compile] literal compile (local@)
+ ENDCASE
+;
+
+: LV.COMPILE.STORE ( index -- )
+ 1+ \ adjust for optimised (local!), LocalsPtr points above vars
+ CASE
+ 1 OF compile (1_local!) ENDOF
+ 2 OF compile (2_local!) ENDOF
+ 3 OF compile (3_local!) ENDOF
+ 4 OF compile (4_local!) ENDOF
+ 5 OF compile (5_local!) ENDOF
+ 6 OF compile (6_local!) ENDOF
+ 7 OF compile (7_local!) ENDOF
+ 8 OF compile (8_local!) ENDOF
+ dup [compile] literal compile (local!)
+ ENDCASE
+;
+
+: LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name )
+\ ." LV.COMPILER.LOCAL name = " dup count type cr
+ lv.match
+ IF ( index )
+ lv.compile.fetch
+ true
+ ELSE
+ drop false
+ THEN
+;
+
+: LV.CLEANUP ( -- , restore stack frame on exit from colon def )
+ lv-#names @
+ IF
+ compile (local.exit)
+ THEN
+;
+: LV.FINISH ( -- , restore stack frame on exit from colon def )
+ lv.cleanup
+ lv-#names off
+ local-compiler off
+;
+
+: LV.SETUP ( -- )
+ 0 lv-#names !
+;
+
+: LV.TERM
+ ." Locals turned off" cr
+ lv-#names off
+ local-compiler off
+;
+
+if.forgotten lv.term
+
+}private
+
+: (LOCAL) ( adr len -- , ANSI local primitive )
+ dup
+ IF
+ lv-#names @ lv_max_vars >= abort" Too many local variables!"
+ lv-#names @ lv-names place
+\ Warn programmer if local variable matches an existing dictionary name.
+ lv-#names @ lv-names find nip
+ IF
+ ." (LOCAL) - Note: "
+ lv-#names @ lv-names count type
+ ." redefined as a local variable in "
+ latest id. cr
+ THEN
+ 1 lv-#names +!
+ ELSE
+\ Last local. Finish building local stack frame.
+ 2drop
+ lv-#names @ dup 0= \ fixed 10/27/99, Thanks to John Providenza
+ IF
+ drop ." (LOCAL) - Warning: no locals defined!" cr
+ ELSE
+ [compile] literal compile (local.entry)
+ ['] lv.compile.local local-compiler !
+ THEN
+ THEN
+;
+
+
+: VALUE
+ CREATE ( n <name> )
+ ,
+ immediate
+ DOES>
+ state @
+ IF
+ [compile] aliteral
+ compile @
+ ELSE
+ @
+ THEN
+;
+
+: TO ( val <name> -- )
+ bl word
+ lv.match
+ IF ( -- index )
+ lv.compile.store
+ ELSE
+ find
+ 1 = 0= abort" TO or -> before non-local or non-value"
+ >body \ point to data
+ state @
+ IF \ compiling ( -- pfa )
+ [compile] aliteral
+ compile !
+ ELSE \ executing ( -- val pfa )
+ !
+ THEN
+ THEN
+; immediate
+
+: -> ( -- ) [compile] to ; immediate
+
+: +-> ( val <name> -- )
+ bl word
+ lv.match
+ IF ( -- index )
+ 1+ \ adjust for optimised (local!), LocalsPtr points above vars
+ [compile] literal compile (local+!)
+ ELSE
+ find
+ 1 = 0= abort" +-> before non-local or non-value"
+ >body \ point to data
+ state @
+ IF \ compiling ( -- pfa )
+ [compile] aliteral
+ compile +!
+ ELSE \ executing ( -- val pfa )
+ +!
+ THEN
+ THEN
+; immediate
+
+: : lv.setup : ;
+: ; lv.finish [compile] ; ; immediate
+: exit lv.cleanup compile exit ; immediate
+: does> lv.finish [compile] does> ; immediate
+
+privatize
projects / pforth / blobdiff