FALSE .IF ********************************************************************** 1/14/86 fig 68000 local variables using dedicated register. These local variables allow the use of named, sized, recursive, truly local, stack resident variables. The number of Local variables per definition is limited by the MAX-LOCALS constant, currently 10. The local variables are searched before the dictionary. BE AWARE that definitions with locals in them put the previous LOCAL-BASE value on the return stack during the execution of that word in order to make it fully rentrant and recursive. USAGE: : EXAMPLE { lv1 lv2 | lv3 -- rv , comment } lv1 and lv2 will have the value of what is on the stack. lv3 follows the '|' and is, therefore, an auto variable whose space is allocated at run time. Not initialized. Anything after a '-' is considered comment. Don't use dash at start of variable name. You can precede the local variable with a cell count. Default is 1. Default is self fetching variables, ie. reference will leave value on stack. Value can be set using " -> " prefix, eg. " 73 -> lv1 " . "{" switches to decimal to interpret the local stack diagram, then restores the previous base at the "}" or if QUIT . Great debugging option would save the compile time tables and string in the dictionary after the ";" . Then could trace and decompile by name. Special thanks to Scott Jones for finding and fixing "the last" of the nasty bugs. Remaining bugs: ?EXIT and ?RETURN don't work, use IF EXIT THEN and IF RETURN THEN instead. Author: Brian Donovan Debuggers: Mike Haas, Phil Burk, Scott Jones, Rene LeBlanc, George Kozlowski. Copyright 1987 Delta Research MOD: PLB 1/30/87 Added VALUE data type, made -> work with both. MOD: MDH 2/16/87 Decimal switch. MOD: PLB/MDH 2/20/87 Added OPTIMIZEOFF for proper compilation. MOD: PLB/RRL 8/6/88 Call CLEANUP-LOCALS for EXIT to prevent crash. Special thanks to Rene LeBlanc for figuring out how to do this. MOD: PLB 8/8/88 Added support for RETURN, LOCAL-RETURN, etc. Corrected spelling in Error messages. MOD: PLB 12/7/88 Add warning for ?EXIT and ?RETURN MOD: PLB 1/19/89 Add range checking for #LOCALS , Increase limit to 12. ************************************************************************* .THEN include? (->value) ju:value anew task-locals ONLY FORTH DEFINITIONS .NEED ALIGN : ALIGN EVEN-UP-DP ; .THEN .NEED RECORD-ARRAY : RECORD-ARRAY CREATE ( items byte/item --- ) HERE >R OVER CELLS ALLOT HERE >R DDUP * DUP ALLOT R SWAP ERASE ALIGN ( items bytes ) ( p-adr a-adr --R-- ) SWAP R> R> ROT 0 DO ( bytes array-adr pointer-adr ) DDUP ! CELL+ >R OVER + R> LOOP 3 XDROP DOES> ( item --- addr ) SWAP CELLS + @ ; .THEN .NEED ARRAY : ARRAY CREATE ( N-CELLS --- ) CELLS ALLOT DOES> ( INDEX --- ADR ) SWAP CELLS + ; .THEN DECIMAL variable locbase 12 CONSTANT MAX-LOCALS ( Increased from 10 to 12 ) USER #LOCALS MAX-LOCALS 31 RECORD-ARRAY LOCAL-NAMES MAX-LOCALS 1+ ARRAY LOCAL#S ( these must be user arrays or Alloc for Mtasking) USER SELF@ USER AUTO-SPACE USER AUTO USER #RETURNS max-locals ARRAY RETURNED-CELLS max-locals ARRAY RETURNED-OFFSETS DEFER OLD-FIND WHAT'S FIND IS OLD-FIND DEFER OLD-QUIT : UNLOCAL-QUIT ( --- ) \ Restore vectors if quit WHAT'S OLD-QUIT IS QUIT WHAT'S OLD-FIND IS FIND locbase @ base ! QUIT ; : LOCAL? ( text ---- ) ( ---false ) ( ---offset cells true ) #LOCALS @ 0 DO DUP I LOCAL-NAMES $= IF DROP #LOCALS @ LOCAL#S @ I LOCAL#S @ - I 1+ LOCAL#S @ I LOCAL#S @ - CELL/ TRUE RETURN THEN LOOP DROP FALSE ; \ Support added for VALUEs 1/30/87 : -> ( --- ) ( PARAM --IN-- ) BL word state @ IF LOCAL? ( only check for locals when compiling) IF DUP 1 = HERE >R OPTIMIZEOFF IF DROP COMPILE (LOCAL!) CELL- ELSE COMPILE (LOCAL-X!) DUP 2- R@ 6 + ! CELLS - THEN R> 2+ W! ELSE here (->value) ( not a local ) THEN ELSE (->value) ( must be non local variable ) THEN ; IMMEDIATE : YES@ ( --- ) SELF@ ON ; IMMEDIATE : NO@ ( --- ) SELF@ OFF ; IMMEDIATE : COMPILE-LOCAL ( offset cells --- ) optimizeoff SELF@ @ HERE >R IF DUP 1 = IF DROP COMPILE (LOCAL@) CELL- R> 4 + W! ELSE COMPILE (LOCAL-X@) 2- R@ 6 + ! R> 2+ W! THEN ELSE CELLS - COMPILE (LOCAL) R> 4 + W! THEN ; : TOTAL-LOCALS ( --- #CELLS ) #LOCALS @ LOCAL#S @ ; : CLEANUP-LOCALS ( -- , compile cleanup of local stuff ) #RETURNS @ IF SELF@ @ YES@ #RETURNS @ 0 DO I RETURNED-OFFSETS @ I RETURNED-CELLS @ COMPILE-LOCAL LOOP SELF@ ! THEN HERE optimizeoff COMPILE (DROP-LOCALS) TOTAL-LOCALS SWAP 2+ W! optimizeoff COMPILE LOCAL-END ; \ PLB - pop DO LOOP info from return stack. : ( --- ) ( N-CELLS --LOOP-- ) ( N --INLINE-- ) r@ ( save return address ) inline@ @ 1+ ( also drop return address ) xrdrop loop-drop ( restore ILOOP & JLOOP ) >r ; ( called ) : LOCAL-RETURN ( --- ) do-loop-nest ( -- #LOOP-CELLS ) dup IF compile 2- , ELSE drop THEN cleanup-locals ( must be between LOOPS and EXIT ) compile exit ; : LOCAL-FIND ( ADR --- ADR FALSE | CFA -1or1 ) BEGIN DUP LOCAL? WHILE COMPILE-LOCAL DROP BL WORD REPEAT OLD-FIND 2DUP IF dup ' ; = over ' ;M = OR IF cleanup-locals ( ALL DONE ) what's old-find is find what's old-quit is quit #locals off THEN \ dup ' EXIT = IF cleanup-locals THEN \ \ Trap error dup ' ?EXIT = abort" LOCALS - Use: IF EXIT THEN instead of ?EXIT" dup ' ?RETURN = abort" LOCALS - Use: IF RETURN THEN instead of ?RETURN" \ ' RETURN = IF local-return 2drop BL word find THEN ( leave CFA and flag for compiler ) ELSE DROP THEN ; : A-LOCAL ( offset --- offset+ , add local, from HERE and input stream ) \ PLB - Check for overflow! #locals @ max-locals >= IF cr ." {Sorry - only " max-locals . ." local variables allowed!}" cr abort THEN \ -------------------------- HERE NUMBER? \ if number then must be followed by name. IF DROP CELLS ( sp-offset var-size -) BL WORD $" }" $= ?ABORT" Unpaired local definition!" ELSE CELL THEN ( offset size ) AUTO @ IF DUP AUTO-SPACE +! THEN OVER #LOCALS @ LOCAL#S ! + HERE #LOCALS @ LOCAL-NAMES $MOVE 1 #LOCALS +! ; : SET-AUTO ( --- ) AUTO @ IF HERE 6 + optimizeoff COMPILE (AUTO-INIT-LOCAL) AUTO-SPACE @ SWAP W! ELSE optimizeoff COMPILE (INIT-LOCAL) THEN ; : GET-RETURNS ( --- ) ( "}" ... --IN-- ) BEGIN BL WORD DUP " }" $= WHILE-NOT LOCAL? NOT ?ABORT" Returned parameters must be local variables!" #RETURNS @ RETURNED-CELLS ! #RETURNS @ RETURNED-OFFSETS ! 1 #RETURNS +! REPEAT DROP ; : GOT- ( --- ) ( "--" or "-->" at HERE ) HERE " -->" $= IF GET-RETURNS ( ." auto returns " ) ELSE ASCII } PARSE ( -- adr cnt ) 2DROP ( ." no returns " ) THEN ; : { ( --- ) base @ locbase ! decimal [] YES@ #LOCALS off #RETURNS OFF AUTO-SPACE OFF AUTO OFF 0 ( init-offset ) WHAT'S FIND IS OLD-FIND WHAT'S QUIT IS OLD-QUIT ' UNLOCAL-QUIT IS QUIT ' LOCAL-FIND IS FIND \ BEGIN BL WORD 1+ C@ CASE ASCII - OF #LOCALS @ LOCAL#S ! GOT- SET-AUTO locbase @ base ! RETURN ENDOF ASCII | OF AUTO ON ENDOF ASCII } OF #LOCALS @ LOCAL#S ! SET-AUTO locbase @ base ! RETURN ENDOF SWAP A-LOCAL SWAP ENDCASE AGAIN ; IMMEDIATE ONLY FORTH