This is the second patch for adding support to OpenBIOS. This adds the bulk of the local variable code to OpenBIOS.
--- forth/util/util.fs | 558 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 files changed, 558 insertions(+), 0 deletions(-)
diff --git a/forth/util/util.fs b/forth/util/util.fs index 6f549bf..f55b0be 100644 --- a/forth/util/util.fs +++ b/forth/util/util.fs @@ -93,3 +93,561 @@ 2dup " tell" is-relay 2drop ; + + + +\ ------------------------------------------------------------------------- +\ Local Variable Support +\ ------------------------------------------------------------------------- + +\ Creates an array variable +: ARRAY ( cellCount - ) + DEPTH 0= IF + CR ." Please specify an array size." CR + EXIT + THEN + + \ Compile-time behavior + CREATE CELL * 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 CELL * + \ 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 CELL * getBaseAddress + ! +; + +\ Sets the second local variable's value +: Local1! ( x - ) + 1 CELL * getBaseAddress + ! +; + +\ Sets the third local variable's value +: Local2! ( x - ) + 2 CELL * getBaseAddress + ! +; + +\ Sets the fourth local variable's value +: Local3! ( x - ) + 3 CELL * getBaseAddress + ! +; + +\ Sets the fifth local variable's value +: Local4! ( x - ) + 4 CELL * getBaseAddress + ! +; + +\ Sets the sixth local variable's value +: Local5! ( x - ) + 5 CELL * getBaseAddress + ! +; + +\ Sets the seventh local variable's value +: Local6! ( x - ) + 6 CELL * getBaseAddress + ! +; + +\ Sets the eighth local variable's value +: Local7! ( x - ) + 7 CELL * getBaseAddress + ! +; + +\ Sets the ninth local variable's value +: Local8! ( x - ) + 8 CELL * getBaseAddress + ! +; + +\ Sets the tenth local variable's value +: Local9! ( x - ) + 9 CELL * getBaseAddress + ! +; + +\ Sets the eleventh local variable's value +: Local10! ( x - ) + 10 CELL * getBaseAddress + ! +; + +\ Sets the twelfth local variable's value +: Local11! ( x - ) + 11 CELL * 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 CELL * +; + + +\ **** 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 localStack ! ( x - ) + localStackTop 1 + TO localStackTop + localStackTop maxStackSize = + abort" Local stack overflow!" +; + + +\ Removes the top local stack value and places it into the data stack +: popLocalStack ( L:x - x ) + localStackTop 1 - TO localStackTop + localStackTop localStack @ +; + + +12 CONSTANT localVariableLimit +\ ***** sets up local variables ****** +: { ( "char" - ) + initLocalTable + \ localVariableLimit CELL * ( 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@ + CELL 0 * getBaseAddress + @ +; + +\ returns the second local variable's value +: Local1@ + CELL 1 * getBaseAddress + @ +; + +\ returns the third local variable's value +: Local2@ + CELL 2 * getBaseAddress + @ +; + +\ returns the fourth local variable's value +: Local3@ + CELL 3 * getBaseAddress + @ +; + +\ returns the fifth local variable's value +: Local4@ + CELL 4 * getBaseAddress + @ +; + +\ returns the sixth local variable's value +: Local5@ + CELL 5 * getBaseAddress + @ +; + +\ returns the seventh local variable's value +: Local6@ + CELL 6 * getBaseAddress + @ +; + +\ returns the eighth local variable's value +: Local7@ + CELL 7 * getBaseAddress + @ +; + +\ returns the ninth local variable's value +: Local8@ + CELL 8 * getBaseAddress + @ +; + +\ returns the tenth local variable's value +: Local9@ + CELL 9 * getBaseAddress + @ +; + +\ returns the eleventh local variable's value +: Local10@ + CELL 10 * getBaseAddress + @ +; + +\ returns the twelfth local variable's value +: Local11@ + CELL 11 * 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
Let me comment on the code, independently of if I think using local var names is a good idea at all.
- DEPTH 0= IF
CR ." Please specify an array size." CREXIT- THEN
You shouldn't blindly continue when you detect an error; use ABORT instead, or ABORT" since you want to print something.
Don't check stack depth, it is useless. It doesn't work when you forgot to pass a parameter but there is other stuff on the stack already (the common case). Your check also doesn't work if there is a negative number of parameters on the stack (the next most common case...)
Just kill this part.
- CREATE CELL * ALLOT \ creates and initializes the instance
CELL * is CELLS (which is a standard Forth word, CELL is not).
- DEPTH 2 < IF
CR ." Please specify an index number." CRdrop \ removes the address of the array instance-1 throw \ stop normal execution after error- THEN
-1 THROW is ABORT Same thing here, just kill this code.
+; immediate
Defining words should not be immediate in most cases, including here.
+\ 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
+;
: really-get-base-address getBaseAddress ; : really-really-get-base-address really-get-base-address ;
And don't use CamelCase.
+\ Sets the first local variable's value +: Local0! ( x - )
- 0 CELL * getBaseAddress + !
+;
You can do something smarter than this...
+\ Sets the twelfth local variable's value +: Local11! ( x - )
- 11 CELL * getBaseAddress + !
+;
...why stop at 11?
+: calculateNeededMemory ( "char" - n )
- 0 TO variableCount
- begin
parse-word0= if \ if there is no more text to parsedroptrueelsedup " ;" comp0= if \ if the semicolon is encountereddrop \ drop the duplicated addressfalseelse" }" comp0= if \ if '}' character is encounteredtrue \ end loop because '}' marks end of local variableselsevariableCount 1 + TO variableCountfalsethenthenthen- until
- variableCount CELL *
+;
Factor this? You shouldn't ever use a variable that is used as a temp inside a word.
+: allocateMemory ( n - addr )
- alloc-mem dup 0= if
dropcr cr 10 spaces abort" Failed to allocate memory for localvariables!" cr cr
- then
+;
alloc-mem is way too slow to be used on every function call. Statically allocate a locals stack, or put it on an existing stack, or something like that.
+\ Declares the size of the local variable table +48 CONSTANT localTableSize
+\ Declare the local variable table +localTableSize ARRAY localVariableTable
You have 48 but can only access 12?
+: getLocalRecordCount
- arrayCount 4 /
+;
Oh. Use a struct?
I'll stop here. There are two good ways to implement locals (or anything else, really): 1) Make it _simple_: you can do locals in about 20 or 30 lines of code. 60 is fine, too. 2) Make it efficient: don't allocate from a heap, don't run much code on the hot paths. This will be much smaller code as well, but perhaps trickier to understand.
Segher
-
Programmingkid -
Segher Boessenkool