Signed-off-by: John Arbuckle programmingkidx@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 +