[PATCH] Adds local variable support to OpenBIOS - one of the key ingredients needed to boot Mac OS X.

[Programmingkid]

Signed-off-by: John Arbuckle

---
 forth/bootstrap/interpreter.fs |   50 +++-
 forth/util/util.fs             |  544 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 580 insertions(+), 14 deletions(-)

diff --git a/forth/bootstrap/interpreter.fs b/forth/bootstrap/interpreter.fs
index 5187058..769633f 100644
--- a/forth/bootstrap/interpreter.fs
+++ b/forth/bootstrap/interpreter.fs
@@ -40,26 +40,20 @@
 \ 7.3.9.2.4 Miscellaneous dictionary
 \

-\ interpreter. This word checks whether the interpreted word
-\ is a word in dictionary or a number. It honours compile mode 
-\ and immediate/compile-only words.

-: interpret 
-  0 >in !
-  begin
-    parse-word dup 0> \ was there a word at all?
-  while
-    $find 
+\ Most of the old version of interpret
+: old-interpret  ( addr len -- )
+ $find 
     if
       dup flags? 0<> state @ 0= or if
         execute
       else
-        ,             \ compile mode && !immediate
+        ,             \ Compile mode && !immediate
       then
-    else              \ word is not known. maybe it's a number
+    else              \ Word is not known. maybe it's a number
       2dup $number
       if
-        span @ >in !  \ if we encountered an error, don't continue parsing
+        span @ >in !  \ If we encountered an error, don't continue parsing
         type 3a emit
    -13 throw
       else
@@ -70,9 +64,37 @@
     depth 0<      if -4 throw then
     rdepth 200 >= if -5 throw then 
     rdepth 0<     if -6 throw then
+;  
+  
+
+Defer lfind-defer		  
+false VALUE using-locals
+
+\ The refactored interpret	-	supports local variables
+: interpret  ( -- )
+ 0 >in !
+  begin
+    parse-word                ( addr len )
+    dup                       ( addr len len1 )
+    0>                        ( addr len flag )       \ Was there a word at all?
+  while                       ( addr len )
+     using-locals true =  IF  ( addr len )            \ If local variables are being used
+        2dup                  ( addr len addr1 len1 )
+        lfind-defer           ( addr len flag )
+        not  IF               ( addr len )            \ If symbol is not a local variable
+           old-interpret      ( )
+        ELSE                                          \ Else clean up the stack
+           2drop              ( )
+        THEN
+	
+     ELSE	\ If not using local variables
+        old-interpret        ( addr len -- )
+     THEN
+	
   repeat
-  2drop
-  ;
+  2drop         \ Removes the addr len pair if the loop ends at the WHILE word
+;
+

: refill ( -- )
    ib #ib @ expect 0 >in ! ;
diff --git a/forth/util/util.fs b/forth/util/util.fs
index 6f549bf..529b722 100644
--- a/forth/util/util.fs
+++ b/forth/util/util.fs
@@ -93,3 +93,547 @@
   2dup " tell" is-relay
   2drop
 ;
+
+
+\ -------------------------------------------------------------------------
+\                       Local Variable Support
+\ -------------------------------------------------------------------------
+
+\ Creates an array variable
+: ARRAY ( cellCount - )
+	DEPTH 0<  IF
+		CR ." Please specify an array size." CR
+		abort
+	THEN
+	
+	\ Compile-time behavior
+	CREATE CELLS ALLOT		\ Creates and initializes the instance
+	
+	DOES>
+	
+	\ Run-time behavior	
+	DEPTH 2 <  IF
+		CR ." Please specify an index number." CR
+		drop		\ Removes the address of the array instance
+		-1 throw	\ Stop normal execution after error
+	THEN
+	
+	SWAP CELLS +	\ Calculates address to return 
+; immediate
+
+
+\ Declare the local-base-address VALUE
+0 VALUE local-base-address
+
+\ Returns the base address used for the local words
+: get-base-address ( - addr )
+	local-base-address
+;
+
+\ Sets the base address used for the local words
+: set-base-address ( addr -  )
+	TO local-base-address
+;
+
+
+\ Sets the first local variable's value
+: Local0!	( x - )
+	0 CELLS get-base-address + !
+;
+
+\ Sets the second local variable's value
+: Local1!	( x - )
+	1 CELLS get-base-address + !
+;
+
+\ Sets the third local variable's value
+: Local2!	( x - )
+	2 CELLS get-base-address + !
+;
+
+\ Sets the fourth local variable's value
+: Local3!	( x - )
+	3 CELLS get-base-address + !
+;
+
+\ Sets the fifth local variable's value
+: Local4!	( x - )
+	4 CELLS get-base-address + !
+;
+
+\ Sets the sixth local variable's value
+: Local5!	( x - )
+	5 CELLS get-base-address + !
+;
+
+\ Sets the seventh local variable's value
+: Local6!	( x - )
+	6 CELLS get-base-address + !
+;
+
+\ Sets the eighth local variable's value
+: Local7!	( x - )
+	7 CELLS get-base-address + !
+;
+
+\ Sets the ninth local variable's value
+: Local8!	( x - )
+	8 CELLS get-base-address + !
+;
+
+\ Sets the tenth local variable's value
+: Local9!	( x - )
+	9 CELLS get-base-address + !
+;
+
+\ Sets the eleventh local variable's value
+: Local10!	( x - )
+	10 CELLS get-base-address + !
+;
+
+\ Sets the twelfth local variable's value
+: Local11!	( x - )
+	11 CELLS get-base-address + !
+;
+
+
+\ **** Calculates the needed amount of memory for local variables ****
+0 value variableCount
+: calculate-needed-memory ( - n )
+	0 TO variableCount
+	>in @	\ Keep track of where the pointer was	
+	
+	begin
+		parse-word
+		0=  if			\ If there is no more text to parse
+			drop
+			true
+		else
+			dup " ;" comp 
+			0=  if		\ If the semicolon is encountered
+				drop	\ Drop the duplicated address 
+				false
+			else
+				" }" comp 
+				0=  if		\ If '}' character is encountered
+					true	\ End loop because '}' marks end of local variables 
+				else	
+					variableCount 1 + TO variableCount
+					false
+				then
+			then
+		then
+	until	
+	
+	>in ! \ Reset the pointer
+	variableCount CELLS	
+; 
+
+
+\ **** allocates the memory for local variables ****
+: allocate-memory	( n - addr )
+	alloc-mem dup 0=  if 
+		drop
+		cr cr 10 spaces abort" Failed to allocate memory for local variables!" cr cr
+	then
+;
+
+
+
+\ Declares the size of the local variable table
+48 CONSTANT #local-table-elements
+
+\ Declare the local variable table
+#local-table-elements ARRAY local-variable-table
+
+\ Keeps track of end of array 
+0 VALUE #filled-local-table-elements
+
+\ Clears the local variable table
+: init-local-table ( - )
+	
+	\ Free all the dynamically allocated memory
+	#filled-local-table-elements 0 ?do
+		I 3 + local-variable-table @	( addr )
+		free-mem	( ) 
+	4 +loop
+	
+	0 local-variable-table #local-table-elements erase
+	0 TO #filled-local-table-elements
+;
+
+\ Adds a local variable symbol to the local variable table
+: add-local ( addr len order initflag -  )
+	depth 4 <  if
+		cr ." The stack needs at least 4 values to add a local variable." cr
+		exit
+	then
+	
+	\ Add to the end of the table
+	#filled-local-table-elements 0 + local-variable-table !		\ initflag
+	#filled-local-table-elements 1 + local-variable-table !		\ order
+	#filled-local-table-elements 2 + local-variable-table !		\ len
+	#filled-local-table-elements 3 + local-variable-table !		\ addr
+	
+	\ Allocate memory for the symbol
+	#filled-local-table-elements 2 + local-variable-table @		( length ) 
+	alloc-mem	( memaddr )
+	dup			( memaddr memaddr )
+	dup			( memaddr memaddr memaddr )
+	
+	\ Called only when memaddr = 0
+	0=	 if		( memaddr memaddr )
+		cr ." Failed to allocate memory in add-local!" cr   ( memaddr memaddr )	
+	then
+	
+	\ Copy local variable name to a safe location
+	#filled-local-table-elements 3 + local-variable-table @			( memaddr memaddr addr ) 
+	swap										( memaddr addr memaddr )
+	#filled-local-table-elements 2 + local-variable-table @			( memaddr addr memaddr length )
+	move										( memaddr )
+	#filled-local-table-elements 3 + local-variable-table !			( )
+	
+	\ Increment #filled-local-table-elements
+	#filled-local-table-elements 4 + TO #filled-local-table-elements
+;
+
+\ Prints the local variable table
+: print-local-table
+
+	#filled-local-table-elements 0=  if
+		cr ." No variables loaded" cr 
+		exit
+	then
+
+	#filled-local-table-elements 0 ?do
+		cr ." Variable name: " 
+		I 3 + local-variable-table @ 
+		I 2 + local-variable-table @
+		type
+		
+		."  Order: " 
+		I 1 + local-variable-table @ .
+		
+		."  Init Flag: " 
+		I 0 + local-variable-table @ .
+	4  +loop 
+;
+
+\ Finds a local variable symbol in the local variable table
+\ Returns its order or -1 on failure
+: get-order ( addr len - order ) 
+	\ If the address and length are missing
+	depth 2 <  if
+		cr ." Address and length are required on the stack to use get-order!" cr
+		-1 throw	\ Ends execution
+	then
+
+	#filled-local-table-elements 0 ?do
+		over ( addr len addr )
+		I 3 +	( addr len addr addrindex )
+		local-variable-table @    ( addr len addr addr1 )
+		2 pick	( addr len addr addr1 len ) 
+		
+		\ Check if lengths of two strings are the same length
+		dup		( addr len addr addr1 len len )	
+		I 2 + local-variable-table @		( addr len addr addr1 len len len1)
+		=  if		( addr len addr addr1 len )   \ If lengths are equal	
+			comp	( addr len flag)
+			0=  if		( addr len flag )	\ If the symbol is found
+				2drop    (  )
+				I 1 + local-variable-table @	( order )
+				unloop
+				exit
+			then
+	
+		else	\ If the lengths are different
+			3drop	( addr len )
+		then
+		
+   \ Increment the index by 4
+	4  +loop
+	2drop ( addr len - )
+	 -1		\ Returns -1 for the order if the symbol is not found
+;
+
+
+\ **** read the local variables in the input stream **** 
+0 VALUE use-top-stack-value
+0 VALUE index
+0 VALUE local-variable-memory
+
+: read-local-variables  ( "char" - )
+	0 TO index
+	true TO use-top-stack-value
+	
+	begin
+	parse-word	( addr len )
+	  dup		( addr len len )
+	  0>		( addr len flag )
+	while		( addr len )
+		2dup	( addr len addr len )
+		drop	( addr len addr )
+		" }"	( addr len addr addr len ) 
+		comp	( addr len flag )
+		0=  if	( addr len )    \ If end of local variables
+			drop	( addr )
+			drop	( )
+			exit	( )
+		then
+				
+		2dup	( addr len addr len )
+		drop	( addr len addr )
+		" ;"	( addr len addr addr len )
+		comp	( addr len flag )
+		0=		( addr len flag )
+		
+		if		( addr len )		\ If not using top stack value for local variables
+			false TO use-top-stack-value	( addr len )
+			2drop						( )
+		else						\ Add local variable to table
+			index use-top-stack-value		( addr len order use-top-stack-value )
+			add-local			(  )
+			index 1 + TO index		\ Increment index
+		then
+		
+	repeat
+	drop	( addr )
+	drop	( )
+;
+
+
+\ Sets the stack size
+1000 CONSTANT max-stack-size
+
+\ Declare the local stack
+max-stack-size ARRAY local-stack
+
+\ Declare the stack top pointer
+0 VALUE local-stack-top
+
+\ Adds to the top of the local stack
+: push-local-stack ( x - L:x )
+	local-stack-top max-stack-size 1 - > 
+		if
+			cr ." Local stack overflow!" cr
+			max-stack-size TO local-stack-top		\ Sets local-stack-top back to the max size
+		then
+	local-stack-top local-stack ! ( x - )
+	local-stack-top 1 + TO local-stack-top
+;
+
+
+\ Removes the top local stack value and places it into the data stack
+: pop-local-stack ( L:x - x )
+	local-stack-top 1 - TO local-stack-top    \ Decrement local-stack-top
+	local-stack-top 0< if                     \ If popping too many items
+		cr ." Local stack underflow!" cr
+		0 TO local-stack-top                   \ Sets local-stack-top back to zero
+		abort
+	then
+	local-stack-top local-stack @	
+;
+
+
+\ ***** sets up local variables ******
+: {		( -- )
+	init-local-table
+	calculate-needed-memory		( memorySize )
+	allocate-memory				( memorySize - addr )
+	TO local-variable-memory	( )
+	read-local-variables			( )
+	TRUE TO using-locals
+	
+	\ Add code to the current definition 
+
+	\ Saves the old base address
+	postpone get-base-address
+	postpone push-local-stack
+	
+	\ Sets the base address to this definition's reserved memory 
+	local-variable-memory	
+	postpone literal
+	postpone set-base-address
+	
+	\ Add code to initialize the variables if needed
+	0 #filled-local-table-elements 4 -  ?do
+		I 0 + local-variable-table @		( flag )    \ Get the init flag
+		true				( flag true )
+		=					( flag1 )
+		if
+			I 4 /			( variable number )
+			case 
+				0 of ['] Local0! , endof
+				1 of ['] Local1! , endof
+				2 of ['] Local2! , endof
+				3 of ['] Local3! , endof
+				4 of ['] Local4! , endof
+				5 of ['] Local5! , endof
+				6 of ['] Local6! , endof
+				7 of ['] Local7! , endof
+				8 of ['] Local8! , endof
+				9 of ['] Local9! , endof
+				10 of ['] Local10! , endof
+				11 of ['] Local11! , endof
+				
+				cr ." Can't save to local variable! " cr 
+				exit
+			
+			endcase
+		then 
+	-4  +loop
+   
+; immediate	   \ Declares this word as a compiler directive
+
+
+
+\ Sets values for local variables
+: ->	( - )
+	parse-word ( addr len )
+	get-order ( order )
+	dup		( order order )
+	-1 =	( order flag )
+	
+	if	\ If the symbol isn't found
+		cr ." Symbol is not a local variable! " cr
+		drop	( )
+		exit
+	then
+	
+	case 
+		0 of ['] Local0! , endof
+		1 of ['] Local1! , endof
+		2 of ['] Local2! , endof
+		3 of ['] Local3! , endof
+		4 of ['] Local4! , endof
+		5 of ['] Local5! , endof
+		6 of ['] Local6! , endof
+		7 of ['] Local7! , endof
+		8 of ['] Local8! , endof
+		9 of ['] Local9! , endof
+		10 of ['] Local10! , endof
+		11 of ['] Local11! , endof
+		
+		cr ." Can't save to local variable! " cr 
+		exit
+		
+	endcase
+	
+; immediate
+
+
+\ Returns the first local variable's value
+: Local0@
+	0 CELLS get-base-address + @
+;
+
+\ Returns the second local variable's value
+: Local1@
+	1 CELLS get-base-address + @
+;
+
+\ Returns the third local variable's value
+: Local2@
+	2 CELLS get-base-address + @
+;
+
+\ Returns the fourth local variable's value
+: Local3@
+	3 CELLS get-base-address + @
+;
+
+\ Returns the fifth local variable's value
+: Local4@
+	4 CELLS get-base-address + @
+;
+
+\ Returns the sixth local variable's value
+: Local5@
+	5 CELLS get-base-address + @
+;
+
+\ Returns the seventh local variable's value
+: Local6@
+	6 CELLS get-base-address + @
+;
+
+\ Returns the eighth local variable's value
+: Local7@
+	7 CELLS get-base-address + @
+;
+
+\ Returns the ninth local variable's value
+: Local8@
+	8 CELLS get-base-address + @
+;
+
+\ Returns the tenth local variable's value
+: Local9@
+	9 CELLS get-base-address + @
+;
+
+\ Returns the eleventh local variable's value
+: Local10@
+	10 CELLS get-base-address + @
+;
+
+\ Returns the twelfth local variable's value
+: Local11@
+	11 CELLS get-base-address + @
+;
+
+
+\ Determines if a symbol is a local variable
+\ Returns true if the symbol is a local variable, false otherwise
+: LFIND	( addr len - flag )	
+	depth 2 < if	\ If the address and length are not on the stack
+		exit
+	then
+
+	get-order	( addr len - n )
+	dup			( n n1 )
+	-1 = if		( n )    \ If the symbol isn't a local variable
+		drop     ( )
+		false    ( flag )
+		
+	else	\ If the symbol is a local variable
+		case  ( n )
+			0 of ['] Local0@ , endof
+			1 of ['] Local1@ , endof
+			2 of ['] Local2@ , endof
+			3 of ['] Local3@ , endof
+			4 of ['] Local4@ , endof
+			5 of ['] Local5@ , endof
+			6 of ['] Local6@ , endof
+			7 of ['] Local7@ , endof
+			8 of ['] Local8@ , endof
+			9 of ['] Local9@ , endof
+			10 of ['] Local10@ , endof
+			11 of ['] Local11@ , endof
+			
+			\ Default case
+			cr ." Could not compile local variable!" cr
+			TRUE	( flag ) 
+			exit
+			
+		endcase
+
+		." compiled "	\ Display this text when entering a local variable symbol
+		true	( flag )
+	then 
+;
+
+
+\ Redefine colon to clean up after {
+: ;
+	using-locals TRUE = 
+	if
+		FALSE TO using-locals
+		postpone pop-local-stack
+		postpone set-base-address
+	then
+	postpone ; 
+; immediate
+
+' lfind is lfind-defer		\ Makes lfind work in INTERPRET
+