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@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 + +