[OpenBIOS] [PATCH] Adds local variable support to OpenBIOS.
Programmingkid
programmingkidx at gmail.com
Tue Aug 28 03:26:05 CEST 2012
Here is the patch for local variable support. I have made several improvements to the code using the feedback I received.
Signed-off-by: John Arbuckle <programmingkidx at gmail.com>.
---
forth/bootstrap/interpreter.fs | 42 ++-
forth/util/util.fs | 567 ++++++++++++++++++++++++++++++++++++++++
2 files changed, 597 insertions(+), 12 deletions(-)
diff --git a/forth/bootstrap/interpreter.fs b/forth/bootstrap/interpreter.fs
index 5187058..3be9f0c 100644
--- a/forth/bootstrap/interpreter.fs
+++ b/forth/bootstrap/interpreter.fs
@@ -40,16 +40,9 @@
\ 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
+: oldInterpret
+ $find
if
dup flags? 0<> state @ 0= or if
execute
@@ -70,9 +63,34 @@
depth 0< if -4 throw then
rdepth 200 >= if -5 throw then
rdepth 0< if -6 throw then
- repeat
+;
+
+
+Defer mydefer
+false VALUE usingLocals
+
+\ The refactored interpret - supports local variables
+: interpret
+ 0 >in !
+ begin
+ parse-word dup 0> ( addr len flag ) \ was there a word at all?
+ while ( addr len )
+
+ usingLocals true = if ( addr len ) \ if local variables are being used
+ mydefer ( addr len flag )
+ not if ( ) \ if symbol is not a local variable
+ oldInterpret
+ then
+
+ else \ if not using local variables
+ oldInterpret
+ then
+
+ repeat
2drop
- ;
+;
+
+
: refill ( -- )
ib #ib @ expect 0 >in ! ;
diff --git a/forth/util/util.fs b/forth/util/util.fs
index 6f549bf..3f5bb21 100644
--- a/forth/util/util.fs
+++ b/forth/util/util.fs
@@ -93,3 +93,570 @@
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
+: getBaseAddress ( - addr )
+ local-base-address
+;
+
+\ sets the base address used for the local words
+: setBaseAddress ( addr - )
+ TO local-base-address
+;
+
+
+\ Sets the first local variable's value
+: Local0! ( x - )
+ 0 CELLS getBaseAddress + !
+;
+
+\ Sets the second local variable's value
+: Local1! ( x - )
+ 1 CELLS getBaseAddress + !
+;
+
+\ Sets the third local variable's value
+: Local2! ( x - )
+ 2 CELLS getBaseAddress + !
+;
+
+\ Sets the fourth local variable's value
+: Local3! ( x - )
+ 3 CELLS getBaseAddress + !
+;
+
+\ Sets the fifth local variable's value
+: Local4! ( x - )
+ 4 CELLS getBaseAddress + !
+;
+
+\ Sets the sixth local variable's value
+: Local5! ( x - )
+ 5 CELLS getBaseAddress + !
+;
+
+\ Sets the seventh local variable's value
+: Local6! ( x - )
+ 6 CELLS getBaseAddress + !
+;
+
+\ Sets the eighth local variable's value
+: Local7! ( x - )
+ 7 CELLS getBaseAddress + !
+;
+
+\ Sets the ninth local variable's value
+: Local8! ( x - )
+ 8 CELLS getBaseAddress + !
+;
+
+\ Sets the tenth local variable's value
+: Local9! ( x - )
+ 9 CELLS getBaseAddress + !
+;
+
+\ Sets the eleventh local variable's value
+: Local10! ( x - )
+ 10 CELLS getBaseAddress + !
+;
+
+\ Sets the twelfth local variable's value
+: Local11! ( x - )
+ 11 CELLS getBaseAddress + !
+;
+
+
+\ **** Calculates the needed amount of memory for local variables ****
+0 value variableCount
+: calculateNeededMemory ( "char" - 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 ****
+: allocateMemory ( 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 localTableSize
+
+\ Declare the local variable table
+localTableSize ARRAY localVariableTable
+
+\ Keeps track of end of array
+0 VALUE arrayCount
+
+\ gets the number of records in the local variable table
+: getLocalRecordCount
+ arrayCount 4 /
+;
+
+\ Clears the local variable table
+: initLocalTable ( - )
+
+ \ free all the dynamically allocated memory
+ arrayCount 0 ?do
+ I 3 + localVariableTable @ ( addr )
+ free-mem ( )
+ 4 +loop
+
+ 0 localVariableTable localTableSize erase
+ 0 TO arrayCount
+;
+
+\ Adds a local variable symbol to the local variable table
+: addLocal ( 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 table
+ arrayCount 0 + localVariableTable ! \ initflag
+ arrayCount 1 + localVariableTable ! \ order
+ arrayCount 2 + localVariableTable ! \ len
+ arrayCount 3 + localVariableTable ! \ addr
+
+ \ allocate memory for the symbol
+ arrayCount 2 + localVariableTable @ ( length )
+ alloc-mem ( memaddr )
+ dup ( memaddr memaddr )
+ dup ( memaddr memaddr memaddr )
+
+ \ called only when memaddr = 0
+ 0= ( memaddr memaddr flag )
+ if
+ cr ." Failed to allocate memory in addLocal!" cr ( memaddr memaddr )
+ then
+
+ \ copy local variable name to a safe location
+ arrayCount 3 + localVariableTable @ ( memaddr memaddr addr )
+ swap ( memaddr addr memaddr )
+ arrayCount 2 + localVariableTable @ ( memaddr addr memaddr length )
+ move ( memaddr )
+ arrayCount 3 + localVariableTable ! ( )
+
+ \ increment arrayCount
+ arrayCount 4 + TO arrayCount
+;
+
+\ prints the local variable table
+: printLocalTable
+
+ arrayCount 0= if
+ cr ." No variables loaded" cr
+ exit
+ then
+
+ arrayCount 0 ?do
+ cr ." Variable name: "
+ I 3 + localVariableTable @
+ I 2 + localVariableTable @
+ type
+
+ ." Order: "
+ I 1 + localVariableTable @ .
+
+ ." Init Flag: "
+ I 0 + localVariableTable @ .
+ 4
+ +loop
+;
+
+\ Finds a local variable symbol in the local variable table
+\ Returns its order or -1 on failure
+: getOrder ( addr len - order )
+ \ if the address and length are missing
+ depth 2 < if
+ cr ." Address and length are required on the stack to use getOrder!" cr
+ -1 throw \ ends execution
+ then
+
+ arrayCount 0 ?do
+ over ( addr len addr )
+ I 3 + ( addr len addr addrindex )
+ localVariableTable @ ( 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 + localVariableTable @ ( addr len addr addr1 len len len1)
+ = ( addr len addr addr1 len flag)
+
+ if \ if lengths are equal
+ comp ( addr len flag)
+ 0= ( addr len flag )
+ if \ if the symbol is found
+ 2drop ( )
+ I 1 + localVariableTable @ ( order )
+ unloop
+ exit
+ then
+
+ else \ if the lengths are different
+ 3drop ( addr len )
+ then
+
+
+ 4 \ increment the index by 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 useTopStackValue
+0 VALUE index
+0 VALUE localVariableMemory
+
+: readLocalVariables ( "char" - )
+ 0 TO index
+ true TO useTopStackValue
+
+ 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= ( addr len flag )
+
+ 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 useTopStackValue ( addr len )
+ 2drop ( )
+ else \ add local variable to table
+ index useTopStackValue ( addr len order useTopStackValue )
+ addLocal ( )
+ index 1 + TO index \ increment index
+ then
+
+ repeat
+ drop ( addr )
+ drop ( )
+;
+
+
+\ FALSE VALUE usingLocals \ not needed because it is in the interpreter.fs file
+
+\ sets the stack size
+1000 CONSTANT maxStackSize
+
+\ declare the local stack
+maxStackSize ARRAY localStack
+
+\ declare the stack top pointer
+0 VALUE localStackTop
+
+\ Adds to the top of the local stack
+: pushLocalStack ( x - L:x )
+ localStackTop maxStackSize 1 - >
+ if
+ cr ." Local stack overflow!" cr
+ maxStackSize TO localStackTop \ sets localStackTop back to the max size
+ then
+ localStackTop localStack ! ( x - )
+ localStackTop 1 + TO localStackTop
+;
+
+
+\ Removes the top local stack value and places it into the data stack
+: popLocalStack ( L:x - x )
+ localStackTop 1 - TO localStackTop
+ localStackTop 0< if \ if popping too many items
+ cr ." Local stack underflow!" cr
+ 0 TO localStackTop \ sets localStackTop back to zero
+ abort
+ then
+ localStackTop localStack @
+;
+
+
+12 CONSTANT localVariableLimit
+\ ***** sets up local variables ******
+: { ( "char" - )
+ initLocalTable
+ \ localVariableLimit CELLS ( memorySize )
+ calculateNeededMemory ( memorySize )
+ allocateMemory ( memorySize - addr )
+ TO localVariableMemory ( )
+ readLocalVariables ( )
+ TRUE TO usingLocals
+
+ \ add code to the current definition
+
+ \ saves the old base address
+ postpone getBaseAddress
+ postpone pushLocalStack
+
+ \ sets the base address to this definition's reserved memory
+ localVariableMemory
+ postpone literal
+ postpone setBaseAddress
+
+ \ add code to initialize the variables if needed
+ 0 arrayCount 4 - ( end start )
+ ?do
+ I 0 + localVariableTable @ ( 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 )
+ getOrder ( 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 getBaseAddress + @
+;
+
+\ returns the second local variable's value
+: Local1@
+ 1 CELLS getBaseAddress + @
+;
+
+\ returns the third local variable's value
+: Local2@
+ 2 CELLS getBaseAddress + @
+;
+
+\ returns the fourth local variable's value
+: Local3@
+ 3 CELLS getBaseAddress + @
+;
+
+\ returns the fifth local variable's value
+: Local4@
+ 4 CELLS getBaseAddress + @
+;
+
+\ returns the sixth local variable's value
+: Local5@
+ 5 CELLS getBaseAddress + @
+;
+
+\ returns the seventh local variable's value
+: Local6@
+ 6 CELLS getBaseAddress + @
+;
+
+\ returns the eighth local variable's value
+: Local7@
+ 7 CELLS getBaseAddress + @
+;
+
+\ returns the ninth local variable's value
+: Local8@
+ 8 CELLS getBaseAddress + @
+;
+
+\ returns the tenth local variable's value
+: Local9@
+ 9 CELLS getBaseAddress + @
+;
+
+\ returns the eleventh local variable's value
+: Local10@
+ 10 CELLS getBaseAddress + @
+;
+
+\ returns the twelfth local variable's value
+: Local11@
+ 11 CELLS getBaseAddress + @
+;
+
+
+\ determines if a symbol is a local variable
+\ returns true if the symbol is a local variable, false otherwise
+: LFIND ( addr len - )
+ depth 2 < if \ if the address and length are not on the stack
+ exit
+ then
+
+ 2dup ( addr len addr len )
+ getOrder ( addr len addr len - addr len n )
+ dup ( addr len n - addr len n n )
+ -1 = if \ if the symbol isn't a local variable
+ drop ( addr len n - addr len )
+ false ( addr len flag )
+
+ else \ if the symbol is a local variable
+ 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
+
+ \ default case
+ 2drop ( addr len - )
+ cr ." Could not compile local variable!" cr
+ TRUE ( addr len flag )
+ exit
+
+ endcase
+
+ 2drop ( addr len - )
+ ." compiled " \ display this text when entering a local variable symbol
+ true ( addr len flag )
+ then
+;
+
+
+\ Redefine colon to clean up after {
+: ;
+ usingLocals TRUE =
+ if
+ FALSE TO usingLocals
+ postpone popLocalStack
+ postpone setBaseAddress
+ then
+ postpone ;
+; immediate
+
+' lfind is mydefer \ makes lfind work in INTERPRET
+
+
--
1.7.5.4
More information about the OpenBIOS
mailing list