\ 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

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 )

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

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

comp ( addr len n )

0= ( addr len flag )

if \ if the symbol is found

2drop ( addr len - )

I 1 + localVariableTable @

unloop

exit

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 )

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

\ declare the local stack

1000 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

;

\ Removes the top local stack value and places it into the data stack

: popLocalStack ( L:x - x )

localStackTop localStack @

localStackTop 1 - TO localStackTop

;

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

arrayCount 0 ?do

I 0 + localVariableTable @ ( flag ) \ get the init flag

true ( flag true )

= ( flag1 )

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

+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

: 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 )

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

exit

endcase

2drop ( addr len - )

." compiled" \ display this text when entering a local variable symbol

FALSE

then

;

\ Redefine colon to clean up after {

: ;

usingLocals TRUE =

FALSE TO usingLocals

postpone popLocalStack

postpone setBaseAddress

then

postpone ;

; immediate

' lfind is mydefer \ makes lfind work in INTERPRET

\ ************ OVERWRITE THESE WORDS IN interpreter.fs ***************

Defer mydefer

: interpret

0 >in !

begin

parse-word dup 0> \ was there a word at all?

while

usingLocals if

mydefer

\ need to add a code to continue to the next iteration right here

then

$find

dup flags? 0<> state @ 0= or if

execute

else

, \ compile mode && !immediate

then

else \ word is not known. maybe it's a number

2dup $number

span @ >in ! \ if we encountered an error, don't continue parsing

type 3a emit

-13 throw

else

-rot 2drop 1 handle-lit

then

depth 200 >= if -3 throw then

depth 0< if -4 throw then

rdepth 200 >= if -5 throw then

rdepth 0< if -6 throw then

repeat

2drop

;

: print-status ( exception -- )

space

?dup if

dup sys-debug \ system debug hook

case

-1 of s" Aborted." type endof

-2 of s" Aborted." type endof

-3 of s" Stack Overflow." type 0 depth! endof

-4 of s" Stack Underflow." type 0 depth! endof

-5 of s" Return Stack Overflow." type endof

-6 of s" Return Stack Underflow." type endof

-13 of s" undefined word." type endof

-15 of s" out of memory." type endof

-21 of s" undefined method." type endof

-22 of s" no such device." type endof

-100 of endof \ local variable being used

dup s" Exception #" type .

0 state !

endcase

else

state @ 0= if

s" ok"

else

s" compiled"

then

type

then

;