Merge pull request #13 from philburk/fixrom

[pforth] / fth / ansilocs.fth

\ @(#) 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