Signed-off-by: John Arbuckle <programmingkidx(a)gmail.com>
---
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
+
--
1.7.5.4
