X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/bb6b2dcdd9acffabfd373c4c3f6b64a9cc43f335..861862f451bf6fea44c052b8a8733853fa2fe9d9:/fth/ansilocs.fth diff --git a/fth/ansilocs.fth b/fth/ansilocs.fth index 29d9075..735680f 100644 --- a/fth/ansilocs.fth +++ b/fth/ansilocs.fth @@ -1,203 +1,198 @@ -\ @(#) 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, Devid Rosenboom -\ -\ The pForth software code is dedicated to the public domain, -\ and any third party may reproduce, distribute and modify -\ the pForth software code or any derivative works thereof -\ without any compensation or license. The pForth software -\ code is provided on an "as is" basis without any warranty -\ of any kind, including, without limitation, the implied -\ warranties of merchantability and fitness for a particular -\ purpose and their equivalents under the laws of any jurisdiction. -\ -\ 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 ) - , - immediate - DOES> - state @ - IF - [compile] aliteral - compile @ - ELSE - @ - THEN -; - -: TO ( val -- ) - 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 -- ) - 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 +\ @(#) 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 ) + , + DOES> + @ +; + +: TO ( val -- ) + bl word + lv.match + IF ( -- index ) + lv.compile.store + ELSE + find + 0= abort" not found" + >body \ point to data + state @ + IF \ compiling ( -- pfa ) + [compile] aliteral + compile ! + ELSE \ executing ( -- val pfa ) + ! + THEN + THEN +; immediate + +: -> ( -- ) [compile] to ; immediate + +: +-> ( val -- ) + bl word + lv.match + IF ( -- index ) + 1+ \ adjust for optimised (local!), LocalsPtr points above vars + [compile] literal compile (local+!) + ELSE + find + 0= abort" not found" + >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