    title   MICRO FORTH 1.0
*
* MICRO FORTH 1.0
*
*    This is a small fast implementation of a forth language for
* the Motorola 6809 microprocessor. It is unique in that there is
* no interpreter, all words are directly executable.
*
* ?COPY.TXT 1984-2005 Dave Dunfield
* **See COPY.TXT**.
*
* SYSTEM EQUATES
*
WIDTH   EQU 65      TERMINAL SCREEN WIDTH MARGIN
LSTLOK  EQU OSRAM       POINTER TO LAST WORD PROCESSED FROM INPUT BUFFER
TEMP    EQU LSTLOK+2    TEMPORARY STORAGE
INPBUF  EQU TEMP+2      INPUT BUFFER
RSTACK  EQU LSTLOK+256  RETURN STACK
DSTACK  EQU RSTACK+256  DATA STACK
*
    ORG DSTACK      BEGINNING OF FORTH CODE
* INITIALIZATIONS, START UP FORTH
    LDS #RSTACK     SET UP RETURN STACK
    LDU #DSTACK     SET UP DATA STACK
* IF DESIRED, YOU CAN IMPLEMENT A STARTUP MESSAAGE HERE
* INSERT THE MESSAGE AT THE VERY END OF THIS FILE.
*   LDX #USRSPC     POINT TO STARTUP MESSAGE
*   LBSR    PMSG1       DISPLAY IT
    JSR [BOOT+3]    EXECUTE PRESET ROUTINE (USUALLY 'QUIT')
    LBRA    BYE     EXIT FORTH
* SUBROUTINE TO OBTAIN VARIABLES ADDRESS ON STACK.
* USED BY 'VARIABLE' TYPE WORDS
VARIAB  LDX ,S++        GET FOLLOWING ADDRESS
    PSHU    X       SAVE
    RTS         RETURN TO CALLER
* MESSAGES
PROMPT  FCB $0A,$0D     NEW LINE
    FCCZ    'Ok>'       PROMPT
ERMSG1  FCCZ    /Error: '/  ERROR PREFIX
ERMSG2  FCCZ    /' /        ERROR SUFFIX
REDMSG  FCCZ    'Redef: '   RE-DEFINITION INDICATOR
DELMSG  FCB 8,' ',8,0   MESSAGE FOR CHARACTER DELETE
*
* START OF USER DICTIONARY
* DICTIONARY FORMAT:
*   1)  - WORD DESCRIPTOR BYTE, FORMAT:
*   BIT 7       - ALWAYS SET, INDICATES THIS IS DESCRIPTOR BYTE
*   BITS 7-3    - CURRENTLY NOT USED
*   BIT 2       - NO-COMPILE BIT, WORD CANNOT BE USED IN COMPILES
*   BIT 1       - NO-INTERACTIVE BIT, WORD CANNOT BE USED INTERACTIVELY
*   BIT 0       - EXECUTE ON COMPILE BIT, COMPILER EXECUTES WORD IMMEDIATLY
*             INSTEAD OF COMPILING INTO DEFINITION
*   2)  - WORD NAME, VARIABLE LENGTH, STORED BACKWARDS
*   3)  - ADDRESS OF PREVIOUS WORD IN DICTIONARY, ADDRESS MUST POINT TO FIRST
*     BYTE OF CODE WHICH IMMEDIATLY FOLLOWS THIS FIELD IN THE WORD
*
*
* 'DROPN' - DROPS A NUMBER OF WORDS FROM THE STACK
    FCB $80
    FCC 'NPORD'
    FDB 0       ** END OF DICTIONARY **
DROPN   LDD ,U++        GET OPERAND
    ASLB            MULTIPLY BY
    ROLA            TWO FOR WORD STACK ENTRIES
    LEAU    D,U     MOVE USER STACK
    RTS
* 'DROP' - DROP ONE WORD FROM THE STACK
    FCB $80
    FCC 'PORD'
    FDB DROPN
DROP    LEAU    2,U     MOVE STACK POINTER
    RTS
* 'DUP' - DUPLICATE TOP OF STACK
    FCB $80
    FCC 'PUD'
    FDB DROP
DUP LDD ,U      GET TOP OF USER STACK
    STD ,--U        DUPLICATE
    RTS
* 'OVER' DUPLICATE ONE DOWN FROM TOP OF STACK
    FCB $80
    FCC 'REVO'
    FDB DUP
OVER    LDD 2,U     GET ELEMENT
    STD ,--U        DUPLICATE
    RTS
* 'ROT' - ROTATE TOP THREE ELEMENTS ON STACK
    FCB $80
    FCC 'TOR'
    FDB OVER
ROT LDD 4,U     GET BOTTOM
    LDX 2,U     GET MIDDLE
    STX 4,U     PUT ON BOTTOM
    BRA SWAP1       DO REST
* 'SWAP' - SWAP TOP TWO ELEMENTS ON STACK
    FCB $80
    FCC 'PAWS'
    FDB ROT
SWAP    LDD 2,U     GET LOWER ONE
SWAP1   LDX ,U      GET TOP
    STX 2,U     PLACE TOP AT LOWER
    STD ,U      PLACE LOWER AT TOP
    RTS
* '0=' - TEST FOR TOS EQUAL TO ZERO
    FCB $80
    FCC '=0'
    FDB SWAP
ZEQU    LDD ,U      GET TOP OF STACK
    BEQ RET1        EQUAL TO ZERO?
    BRA RET0        NO, RETURN ONE
* '=' - TEST FOR EQUALITY
    FCB $80
    FCC '='
    FDB ZEQU
EQUALS  LDD ,U++        GET TOP OF STACK
    CMPD    ,U      COMPARE WITH NEXT
    BEQ RET1        SAME, RETURN 1
    BRA RET0        NO, RETURN ZERO
* '<>' - TEST FOR NOT EQUAL
    FCB $80
    FCC '><'
    FDB EQUALS
NOTEQU  LDD ,U++        GET TOS
    CMPD    ,U      COMPARE WITH NEXT
    BEQ RET0        NOT SAME, RETURN 1
    BRA RET1        NO, RETURN 0
* '>' - TEST FOR GREATER
    FCB $80
    FCC '>'
    FDB NOTEQU
GRTR    LDD 2,U     GET LOWER ELEMENT
    CMPD    ,U++        COMPARE WITH TOS
    BGT RET1        GREATER, RETURN 1
    BRA RET0        NO, RETURN FALSE
* '<' - TEST FOR LESS
    FCB $80
    FCC '<'
    FDB GRTR
LESS    LDD 2,U     GET LOWER ELEMENT
    CMPD    ,U++        COMPARE WITH TOS
    BLT RET1        LOWER, RETURN 1
    BRA RET0        NO, RETURN FALSE
* '>=' - TEST FOR GREATER OR EQUAL TO
    FCB $80
    FCC '=>'
    FDB LESS
GREQU   LDD 2,U     GET LOWER
    CMPD    ,U++        COMPARE WITH TOS
    BLT RET0        LESS, RETURN FALSE
RET1    LDB #1      GET ONE
    BRA RETS        RETURN IT
* '<=' - TEST FOR LESS OR EQUAL TO
    FCB $80
    FCC '=<'
    FDB GREQU
LESEQU  LDD 2,U     GET LOWER
    CMPD    ,U++        COMPARE WITH TOS
    BLE RET1        LOWER OR EQUAL, RETURN ONE
RET0    CLRB            GET ZERO RESULT
RETS    CLRA            ZERO HIGH BYTE
    STD ,U      SAVE ON STACK
    RTS
* '$OUT' - OUTPUT CHARACTER TO TERMINAL
    FCB $80
    FCC 'TUO$'
    FDB LESEQU
DOLOUT  LDD ,U++        GET CHAR FROM STACK
    TFR B,A     PUT IN RIGHT REGISTER
    SSR 33      GET CHAR FROM SYSTEM
    RTS
* ' $IN' - INPUT CHARACTER FROM TERMINAL
    FCB $80
    FCC 'NI$'
    FDB DOLOUT
DOLIN   SSR 34      GET CHAR FROM SYSTEM
    TFR A,B     GET IN RIGHT REGISTER
    CLRA            ZERO HIGH BYTE
    STD ,--U        SAVE ON STACK
    RTS
* 'EMIT' - OUTPUT CHARACTER TO GENERAL OUTPUT
    FCB $80
    FCC 'TIME'
    FDB DOLIN
EMIT    JMP [DISP+3]    EXECUTE OUTPUT ROUTINE IN '(OUT)' VARIABLE
* 'KEY' - GET CHARACTER FROM GENERAL INPUT
    FCB $80
    FCC 'YEK'
    FDB EMIT
KEY JMP [INPT+3]    EXECUTE INPUT ROUTINE IN '(IN)' VARIABLE
* 'U.' - OUTPUT UNSIGNED NUMBER IN CURRENT BASE
    FCB $80
    FCC '.U'
    FDB KEY
UDOT    BRA DOT01       EXECUTE NUMBER OUTPUT ROUTINE
* '.' - OUTPUT SIGNED NUMBER IN CURRENT BASE
    FCB $80
    FCC '.'
    FDB UDOT
DOT LDD ,U      GET NUMBER FROM STACK
    BPL DOT01       IS POSITIVE, ITS OK
    LDB #'-'        GET MINUS SIGN
    PSHU    A,B     SAVE ON STACK
    JSR EMIT        OUTPUT MINUS SIGN
    JSR NEG     NEGATE NUMBER
DOT01   LDA #$FF        END IF STREAM INDICATOR
    PSHS    A       SAVE MARKER ON RETURN STACK
DOT1    LDD BASE+3      GET NUMBER BASE FROM 'BASE' VARIABLE
    PSHU    A,B     SAVE BASE
    JSR USMOD       PERFORM DIVISION
    PULU    A,B     GET REMAINDER
    PSHS    B       SAVE FOR LATER
    LDD ,U      GET RESULT
    BNE DOT1        IF MORE, KEEP GOING
    LEAU    2,U     SKIP LAST RESULT ON STACK
DOT2    LDB ,S+     GET CHARACTER FROM STACK
    LBMI    SPACE       END OF DIGITS, OUTPUT SPACE AND EXIT
    ADDB    #$30        CONVERT TO DECIMAL NUMBER
    CMPB    #$39        IN RANGE?
    BLS DOT3        YES, ITS OK
    ADDB    #7      CONVERT TO ALPHA
DOT3    PSHU    A,B     SAVE ON STACK
    BSR EMIT        OUTPUT CHARACTER
    BRA DOT2        KEEP OUTPUTING
* '-!' - SUBTRACT FROM SELF AND REASSIGN
    FCB $80
    FCC '!-'
    FDB DOT
MSTOR   LDX ,U++        GET ADDRESS
    LDD ,X      GET CONTENTS
    SUBD    ,U++        SUBTRACT TOS
    STD ,X      RESAVE CONTENTS
    RTS
* '+!' - ADD TO SELF AND REASSIGN
    FCB $80
    FCC '!+'
    FDB MSTOR
PSTOR   LDX ,U++        GET ADDRESS
    LDD ,X      GET CONTENTS
    ADDD    ,U++        ADD IS TOS
    STD ,X      RESAVE CONTENTS
    RTS
* 'C!' - CHARACTER (BYTE) STORE OPERATION
    FCB $80
    FCC '!C'
    FDB PSTOR
VSTORC  LDX ,U++        GET ADDRESS
    LDD ,U++        GET DATA FROM STACK
    STB ,X      SAVE IN VARIABLE
    RTS
* '!' - WORD STORE OPERATION
    FCB $80
    FCC '!'
    FDB VSTORC
VSTOR   LDX ,U++        GET ADDRESS
    LDD ,U++        GET DATA
    STD ,X      PERFORM STORE
    RTS
* 'C@' - CHARACTER READ OPERATION
    FCB $80
    FCC '@C'
    FDB VSTOR
VREADC  LDB [,U]        GET CHARACTER FROM ADDRESS
    CLRA            ZERO HIGH BYTE
    BRA SAVSD       MOVE TO STACK
* '@' - WORD READ OPERATION
    FCB $80
    FCC '@'
    FDB VREADC
VREAD   LDD [,U]        GET WORD FROM ADDRESS
    BRA SAVSD       PLACE ON STACK
* '2/' - DIVIDE BY TWO
    FCB $80
    FCC '/2'
    FDB VREAD
SHR LSR ,U      SHIFT HIGH
    ROR 1,U     SHIFT LOW
    RTS
* '2*' - MULTIPLY BY TWO
    FCB $80
    FCC '*2'
    FDB SHR
SHL LSL 1,U     SHIFT LOW
    ROL ,U      SHIFT HIGH
    RTS
* '+' - ADD OPERATOR
    FCB $80
    FCC '+'
    FDB SHL
ADD LDD ,U++        GET TOS
    ADDD    ,U      ADD IN NEXT
    BRA SAVSD       PLACE RESULT ON STACK
* '-' - SUBTRACT OPERATOR
    FCB $80
    FCC '-'
    FDB ADD
SUB LDD 2,U     GET LOWER OPERAND
    SUBD    ,U++        SUBTRACT TOS
SAVSD   STD ,U      PLACE RESULT ON STACK
    RTS
* 'D-' DOUBLE PRECISION SUBTRACTION
    FCB $80
    FCC '-D'
    FDB SUB
DMINUS  LDD 6,U     GET LOW WORD OF LOWER OPERAND
    SUBD    2,U     SUBTRACT LOW WORD OFF HIGHER OPERAND
    STD 6,U     RESAVE LOWER WORD OF OPERAND
    LDD 4,U     GET HIGH WORD OF LOWER OPERAND
    SBCB    1,U     SUBTRACT TOP OF STACK
    SBCB    ,U      WITH BORROW FROM PREVIOUS
    LEAU    4,U     FIX UP STACK
    STD ,U      PLACE HIGH WORD OF RESULT ON STACK
    RTS
* 'D+' - DOUBLE PRECISION ADDITION
    FCB $80
    FCC '+D'
    FDB DMINUS
DPLUS   LDD 2,U     GET LOW WORD OF FIRST OPERAND
    ADDD    6,U     ADD LOW WORD OF SECOND OPERAND
    STD 6,U     RESAVE
    LDD ,U      GET HIGH WORD OF FIRST
    ADCB    5,U     ADD IN HIGH WORD OF
    ADCA    4,U     SECOND WITH CARRY
    LEAU    4,U     FIX UP STACK
    STD ,U      RESAVE
    RTS
* 'U*' - UNSIGNED MULTIPLY
    FCB $80
    FCC '*U'
    FDB DPLUS
UMULT   LDA 1,U
    LDB 3,U
    MUL
    PSHS    A,B
    LDA ,U
    LDB 2,U
    MUL
    PSHS    A,B
    LDA 1,U
    LDB 2,U
    MUL
    ADDD    1,S
    BCC UMUL1
    INC ,S
UMUL1   STD 1,S
    LDA ,U
    LDB 3,U
    MUL
    ADDD    1,S
    BCC UMUL2
    INC ,S
UMUL2   STD 1,S
    PULS    D,X
    STD ,U
    STX 2,U
    RTS
* '*' - SIGNED MULTIPLY
    FCB $80
    FCC '*'
    FDB UMULT
MULT    LDA 1,U
    LDB 3,U
    MUL
    PSHS    A,B
    LDA ,U
    LDB 3,U
    MUL
    ADDB    ,S
    STB ,S
    LDA 1,U
    LDB 2,U
    MUL
    ADDB    ,S
    STB ,S
    PULS    D
    LEAU    2,U
    STD ,U
    RTS
* 'M/MOD' - DIVISION WITH REMAINDER
    FCB $80
    FCC 'DOM/M'
    FDB MULT
MSMOD   CLRA
    CLRB
    LDX #33
MSMODL  ANDCC   #$FE
MSMODM  ROL 5,U
    ROL 4,U
    ROL 3,U
    ROL 2,U
    LEAX    -1,X
    BEQ MSMODD
    ROLB
    ROLA
    CMPD    ,U
    BLO MSMODL
    SUBD    ,U
    ORCC    #1
    BRA MSMODM
MSMODD  STD ,U
    RTS
* 'U/MOD' - UNSIGNED DIVISION WITH REMAINDER
    FCB $80
    FCC 'DOM/U'
    FDB MSMOD
USMOD   LDD ,U++
    CLR ,-U
    CLR ,-U
    STD ,--U
    JSR MSMOD
    LDD ,U++
    STD ,U
    RTS
* '/MOD' - DIVISION GIVING REMAINDER
    FCB $80
    FCC 'DOM/'
    FDB USMOD
SLMOD   LDA 2,U
    PSHS    A
    BPL SLMOD2
    CLRA
    CLRB
    SUBD    2,U
    STD 2,U
    LDA ,S
SLMOD2  EORA    ,U
    PSHS    A
    LDD ,U
    BEQ SLMODR
    BPL SLMOD1
    COMA
    COMB
    ADDD    #1
    STD ,U
SLMOD1  CLRA
    CLRB
    LDX #17
SLMODL  ANDCC   #$FE
SLMODM  ROL 3,U
    ROL 2,U
    LEAX    -1,X
    BEQ SLMODD
    ROLB
    ROLA
    CMPD    ,U
    BLO SLMODL
    SUBD    ,U
    ORCC    #1
    BRA SLMODM
SLMODD  TST 1,S
    BPL SLMOD3
    COMA
    COMB
    ADDD    #1
SLMOD3  STD ,U
    TST ,S++
    BPL SLMODR
    CLRA
    CLRB
    SUBD    2,U
    STD 2,U
SLMODR  RTS
* '/' - DIVISION
    FCB $80
    FCC '/'
    FDB SLMOD
SLASH   BSR SLMOD
    LEAU    2,U
    RTS
* 'AND' - LOGICAL AND
    FCB $80
    FCC 'DNA'
    FDB SLASH
AND LDD ,U++        GET TOP OF STACK
    ANDA    ,U      AND HIGH BYTE
    ANDB    1,U     AND LOW BYTE
    BRA SAVDS       SAVE RESULT AND EXIT
* 'OR' - LOGICAL OR
    FCB $80
    FCC 'RO'
    FDB AND
OR  LDD ,U++        GET TOP OF STACK
    ORA ,U      OR HIGH BYTE
    ORB 1,U     OR LOW BYTE
    BRA SAVDS       SAVE RESULT AND EXIT
* 'XOR' - LOGCAL EXCLUSIVE OR
    FCB $80
    FCC 'ROX'
    FDB OR
XOR LDD ,U++        GET TOP OF STACK
    EORA    ,U      XOR HIGH BYTE
    EORB    1,U     XOR LOW BYTE
    BRA SAVDS       SAVE RESULT AND EXIT
* 'COM' - COMPLEMENT OPERAND
    FCB $80
    FCC 'MOC'
    FDB XOR
COM COM ,U      COMPLEMENT HIGH BYTE
    COM 1,U     COMPLEMENT LOW BYTE
    RTS
* 'NEG' - NEGATE OPERAND
    FCB $80
    FCC 'GEN'
    FDB COM
NEG BSR COM     COMPLEMENT OPERAND
    BRA ONEP        INCREMENT (TWO'S COMPLEMENT)
* 'ABS' - GIVE ABSOLUTE VALUE OF OPERAND
    FCB $80
    FCC 'SBA'
    FDB NEG
ABS LDD ,U      GET VALUE FROM STACK
    BMI NEG     NEGATIVE, CONVERT
    RTS
* '2-' - DECREMENT BY TWO
    FCB $80
    FCC '-2'
    FDB ABS
TWOM    LDD ,U      GET TOP OF STACK
    SUBD    #2      DECREMENT BY TWO
SAVDS   STD ,U      RESAVE TOP OF STACK
    RTS
* '2+' - INCREMENT BY TWO
    FCB $80
    FCC '+2'
    FDB TWOM
TWOP    LDD ,U      GET TOP OF STACK
    ADDD    #2      INCREMENT BY TWO
    BRA SAVDS       RESAVE TOP OF STACK
* '1-' - DECREMENT BY ONE
    FCB $80
    FCC '-1'
    FDB TWOP
ONEM    LDD ,U      GET TOP OF STACK
    SUBD    #1      DECREMENT BY ONE
    BRA SAVDS       RESAVE TOP OF STACK
* '1+' - INCREMENT BY ONE
    FCB $80
    FCC '+1'
    FDB ONEM
ONEP    LDD ,U      GET TOP OF STACK
    ADDD    #1      INCREMENT BY ONE
    BRA SAVDS       RESAVE TOP OF STACK
* 'SKIP' - ADVANCE INPUT POINTER TO NON-BLANK
    FCB $80
    FCC 'PIKS'
    FDB ONEP
QSKIP   LDY INPTR+3     GET CURRENT POSITION IN INPUT BUFFER
QSKI1   LDA ,Y+     GET CHARACTER FROM INPUT BUFFER
    CMPA    #' '        IS IT A SPACE
    BEQ QSKI1       YES, KEEP GOING
    LEAY    -1,Y        BACKUP TO IT
    STY INPTR+3     RESAVE INPUT POINTER
    TSTA            TEST FOR END OF LINE
    RTS
*
* SUBROUTINE TO LOOKUP WORDS IN DICTIONARY FROM INPUT LINE
* ON EXIT: 'Z' IS SET IF WORD NOT FOUND
*   IF WORD IS FOUND ('Z'=0), ITS ADDRESS IS STACKED ON THE
*   DATA STACK, AND THE WORD DESCRIPTOR BYTE IS RETURNED IN
*   THE 'A' ACCUMULATOR
*
LOOKUP  PSHS    X,Y     SAVE REGISTERS
    BSR QSKIP       ADVANCE TO WORD
    STY LSTLOK      SAVE INCASE ERROR
    LDX HERE+3      GET START OF DICTIONARY
* SCAN DICTIONARY, LOOKING FOR WORD
LOK1    PSHS    X       SAVE CURRENT ADDRESS
    LEAX    -2,X        BACKUP PAST PRECEDING ADDRESS
LOK2    LDA ,-X     GET CHARACTER FROM NAME
    BMI LOK3        DECREIPTOR BYTE, START OF WORD
    CMPA    ,Y+     DOES IT MATCH INPUT BUFFER?
    BEQ LOK2        YES, KEEP MATCHING TILL END OF WORD
LOK5    PULS    X       RESTORE POINTER
    LDX ,--X        GET ADDRESS OF PREVIOUS WORD
    BEQ LOK4        END OF DICTIONARY, QUIT
    LDY INPTR+3     RESTORE INPUT POINTER
    BRA LOK1        TRY FOR THIS WORD
LOK3    LDB ,Y      GET NET CHAR FROM INPUT STREAM
    BSR TSTERM      IS IT A TERMINATOR?
    BNE LOK5        NO, WORD DOES NOT MATCH
    PULS    A,B     RESTORE ADDRESS OF WORD
    STD ,--U        SAVE ON STACK
    BSR QSKI1       SKIP TO NEXT NON-BLANK
    LDA ,X      GET DESCRIPTOR BYTE
    ANDCC   #$FB        CLEAR 'Z' FLAG
LOK4    PULS    X,Y,PC
* ROUTINE TO TEST FOR TERMINATOR CHARACTER
TSTERM  CMPB    #' '        IS IT A SPACE?
    BEQ TSTER1      YES, ITS OK
    TSTB            IS IT NULL (END OF LINE)?
TSTER1  RTS
* ''' - TICK: RETURN ADDRESS OF A WORD
    FCB $81
    FCC /'/
    FDB QSKIP
TICK    BSR LOOKUP      LOOK UP WORD
    BNE TSTER1      FOUND, RETURN
    LBRA    LOKERR      WORD NOT FOUND, CAUSE ERROR
* 'EXEC' - EXECUTE AT ADDRESS
    FCB $80
    FCC 'CEXE'
    FDB TICK
EXEC    JMP [,U++]      EXECUTE AT ADDRESS ON [TOS]
* 'NUMBER' - GET NUMBER FROM INPUT STREAM IN CURRENT BASE
    FDB $80
    FCC 'REBMUN'
    FDB EXEC
NUMBER  PSHS    X,Y     SAVE REGS
    LBSR    QSKIP       ADVANCE TO NEXT WORD IN INPUT STREAM
    CMPA    #'-'        IS IT A NEGATIVE NUMBER?
    PSHS    CC      SAVE FLAGS FO LATER TEST
    BNE NUM4        NO, NOT NEGATIVE
    LEAY    1,Y     SKIP '-' SIGN
NUM4    CLRA            START OFF
    CLRB            WITH A ZERO RESULT
    PSHU    A,B     SAVE ON STACK
NUM2    LDB ,Y+     GET CHAR FROM SOUCE
    SUBB    #'0'        CONVERT TO BINARY
    CMPB    #9      IS IT NUMERIC DIGIT?
    BLS NUM1        YES, ITS OK
    SUBB    #7      CONVERT FROM ALPHA
    CMPB    #$0A        IS IT A VALID NUMBER?
    BLO NUM3        NO, CAUSE ERROR
NUM1    CLRA            ZERO HIGH BYTE
    CMPD    BASE+3      ARE WE WITHIN RANGE OF CURRENT BASE
    BHS NUM3        NO, CAUSE ERROR
    PSHS    A,B     SAVE NUMBER
    LDD BASE+3      GET BASE
    PSHU    A,B     STACK
    JSR MULT        PERFORM MULTIPLY (OLD VALUE ALREADY ON DATA STACK)
    PULS    A,B     GET NEW DIGIT BACK
    ADDD    ,U      ADD TO OLD VALUE
    STD ,U      RESAVE OLD VALUE
    LDB ,Y      GET NEXT CHARACTER FROM NUMBER
    LBSR    TSTERM      IS IT A TERMINATOR
    BNE NUM2        NO, KEEP EVALUATING NUMBER
    STY INPTR+3     RESAVE INPUT POINTER
    PULS    CC,X,Y      RESTORE REGISTERS
    BNE NUM5        NO NEGATIVE, DON'T NEGATE
    JSR NEG     NEGATE VALUE
NUM5    LBRA    ONE     RETURN TRUE (SUCCESS)
NUM3    PULS    CC,X,Y      CLEAN UP STACK
    LBRA    ZERO        RETURN FALSE (FAILURE)
* 'SPACE' - DISPLAY A SPACE ON GENERAL OUTPUT
    FCB $80
    FCC 'ECAPS'
    FDB NUMBER
SPACE   LDB #' '        GET A SPACE
    PSHU    A,B     PLACEON DATA STACK
    JMP EMIT        OUTPUT
* 'CR' - DISPLAY CARRIAGE-RETURN, LINE-FEED ON GENERAL OUTPUT
    FCB $80
    FCC 'RC'
    FDB SPACE
CR  LDD #$0D        GET CARRIAGE RETURN
    PSHU    A,B     PLACE ON STACK
    JSR EMIT        OUTPUT TO GENERAL OUTPUT
    LDB #$0A        GET LINE-FEED
    PSHU    A,B     PLACE ON STACK
    JMP EMIT        OUTPUT TO GENERAL OUTPUT
* 'READ' - READ A LINE FROM INPUT DEVICE
    FCB $80
    FCC 'DAER'
    FDB CR
READ    BSR CR      NEW LINE
READNC  LDY #INPBUF     POINT TO INPUT BUFFER
READ1   JSR KEY     GET A KEY
    CMPB    #$0D        IS IT CARRIAGE RETURN
    BEQ READ2       YES, EXIT
    CMPB    #$7F        IS IT DELETE?
    BNE READ3       NO, NORMAL CHARACTER
* DELETE KEY, DELETE PREVIOUS CHARACTER
    LEAU    2,U     REMOVE KEYCODE FROM STACK
    LEAY    -1,Y        BACKUP UP INPUT BUFFER POINTER
    CMPY    #INPBUF     PAST BEGINNING?
    BLO READ        IF SO, RE-INITIATE READ
    LDX #DELMSG     POINT TO DELETE MESSAGE
    BSR PMSG1       DISPLAY
    BRA READ1       GO BACK FOR NEXT KEY
* NORMAL KEY
READ3   STB ,Y+     SAVE KEY IN BUFFER
    JSR EMIT        ECHO KEY
    BRA READ1       GO BACK FOR ANOTHER
* CARRIAGE RETURN, TERMINATE INPUT
READ2   LEAU    2,U     REMOVE KEYCODE FROM STACK
    CLR ,Y      INDICATE END OF INPUT LINE
    LDY #INPBUF     POINT TO INPUT BUFFER
    STY INPTR+3     SET UP INPUT BUFFER POINTER
PMSG2   RTS
* '.MSG' - DISPLAY MESSAGE, ADDRESS ON STACK
    FCB $80
    FCC 'GSM.'
    FDB READ
PMSG    LDX ,U++        GET ADDRESS
PMSG1   LDB ,X+     GET CHARACTER FROM MESSAGE
    BEQ PMSG2       END OF MESSAGE, EXIT
    PSHU    A,B     SAVE ON STACK
    JSR EMIT        OUTPUT TO GENERAL OUTPUT
    BRA PMSG1       GET NEXT CHARACTER
* '.WRD' - DISPLAY A WORD ON GENERAL OUTPUT (STRING)
    FCB $80
    FCC 'DRW.'
    FDB PMSG
PWRD    LDX ,U++        GET ADDRESS OF WORD
PWRD1   LDB ,X+     GET CHARACTER FROM WORD
    LBSR    TSTERM      IS IT A TERMINATOR?
    BEQ PMSG2       YES, QUIT
    PSHU    A,B     SAVE DATA ON STACK
    JSR EMIT        OUTPUT TO GENERAL OUTPUT
    BRA PWRD1       GET NEXT WORD
* 'QUIT - GENERAL COMMAND INTERPRETER, USED TO TERMINATE WORDS
    FCB $80
    FCC 'TIUQ'
    FDB PWRD
QUIT    JSR RPFIX       RESET RETURN STACK
    LDX #PROMPT     POINT TO PROMPT
    BSR PMSG1       DISPLAY PROMPT
    LBSR    READNC      READ A LINE OF INPUT
    JSR SPACE       SEPERATE BY A SPACE
QUI1    JSR QSKIP       ADANCE TO NON-BLANK
    BEQ QUIT        NULL LINE, DO NOTHING
    JSR LOOKUP      LOOK UP WORD
    BEQ QUI2        NOT FOUND, TRY NUMBER
    BITA    #$02        OK TO EXECUTE INTERACTIVLY?
    BNE CONERR      NO, FORCE ERROR
    JSR [,U++]      EXECUTE WORD
    CMPU    #DSTACK     DID STACK UNDERFLOW?
    BLS QUI1        NO, KEEP INTERPRETING
    BSR ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Stack empty'
* NOT A WORD, TRY FOR NUMBER
QUI2    JSR NUMBER      TRY FOR NUMBER
    LDD ,U++        GET FLAG BYTE
    BEQ LOKERR      NOT A NUMBER. INDICATE NOT FOUND
    BRA QUI1        KEEP INTERPRETING
* SUBROUTINE TO GENERATE ERROR MESSAGE, FIRST DISPLAYS 'ERROR:' MESSAGE,
* THEN NAME OF LAST WORD PROCESSED, THEN ERROR MESSAGE TEXT
ERROR   LDX #ERMSG1     GET POINTER TO ERROR MESSAGE PREFIX
    BSR PMSG1       DISPLAY PREFIX
    LDX LSTLOK      GET ADDRESS OF LAST WORD FROM INPUT BUFFER
    BSR PWRD1       DISPLAY WORD
    LDX #ERMSG2     POINT TO ERROR MESSAGE SUFFIX
    BSR PMSG1       DISPLAY SUFFIX
    LDX ,S++        GET ADDRESS OF ERROR MESSAGE
    BSR PMSG1       DISPLAY MESSAGE
    JSR SPFIX       RESET DATA STACK
    BRA QUIT        AND ENTER COMMAND INTREPRETER
* WORD WAS NOT FOUND IN THE DICTIONARY
LOKERR  BSR ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Not found'
* WORD CAN NOT BE EXECUTED INTERACTIVELY
CONERR  BSR ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Cannot execute'
* '>R' - MOVE WORD FROM DATA TO RETURN STACK
    FCB $80
    FCC 'R>'
    FDB QUIT
TOR LDX ,S      GET RETURN ADDRESS
    LDD ,U++        GET DATA FROM DATA STACK
    STD ,S      PLACE ON RETURN STACK
    TFR X,PC        RETURN TO CALLER
* '<R' - MOVE WORD FROM RETURN STACK TO DATA STACK
    FCB $80
    FCC 'R<'
    FDB TOR
FROMR   LDX ,S++        GET RETURN ADDRESS
    LDD ,S++        GET DATA FROM RETURN STACK
    STD ,--U        PLACE ON DATA STACK
    TFR X,PC        RETURN TO CALLER
* 'RP!' - RESET RETURN STACK
    FCB $80
    FCC '!PR'
    FDB FROMR
RPFIX   PULS    A,B     GET RETURN ADDRESS
    LDS #RSTACK     RESET RETURN STACK
    TFR D,PC        RETURN TO CALLER
* 'SP!' - RESET DATA STACK
    FCB $80
    FCC '!PS'
    FDB RPFIX
SPFIX   LDU #DSTACK     RESET DATA STACK
VOC9    RTS
* ''S' - OBTAIN STACK ADDRESS
    FCB $80
    FCC /S'/
    FDB SPFIX
TICS    STU ,--U        SAVE DATA STACK POINTER
    RTS
* 'VLIST' - DISPLAY WORDS IN DICTIONARY
    FCB $80
    FCC 'TSILV'
    FDB TICS
VOC LDX HERE+3      GET ADDRESS OF START OF DICTIONARY
VOC1    JSR CR      NEW LINE
    CLRA            ZERO CHARACTER COUNT
VOC2    PSHS    A,X     SAVE COUNT, CURRENT POSITION
    LEAX    -2,X        BACKUP TO WORD NAME
VOC3    LDB ,-X     GET CHARACTER FROM WORD NAME
    BMI VOC4        DESCRIPTOR BYTE, END OF NAME
    PSHU    A,B     SAVE ON DATA STACK
    JSR EMIT        OUTPUT TO GENERAL OUTPUT
    INC ,S      INCREMENT CHARACTER COUNT
    BRA VOC3        KEEP OUTPUTING
VOC4    JSR SPACE       SEPERATE WITH A SPACE
    PULS    A,X     RESTORE CHARACTER COUNT, POSITION IN DICTIONARY
    INCA            ADVANCE CHARACTER COUNT FOR SPACE
    LDX ,--X        GET ADDRESS OF NEXT WORD
    BEQ VOC9        END OF DICTIONARY, EXIT
    CMPA    #WIDTH      ARE WE BEYOND TERMINAL WIDTH?
    BLO VOC2        NO, ITS OK
    BRA VOC1        CONTINUE ON NEW LINE
* 'BYE' - EXIT FORTH
    FCB $80
    FCC 'EYB'
    FDB VOC
BYE SSR 22      NEW LINE
    SSR 0       EXIT TO SYSTEM
* 'FORGET' - REMOVE ONE OR MORE WORDS FROM DICTIONARY
    FCB $80
    FCC 'TEGROF'
    FDB BYE
FORGET  JSR TICK        LOCATE WORDS ADDRESS
    PULU    X       GET ADDRESS
    CMPX    #USRSPC     IS IT IN KERNAL DICTIONARY?
    BLO PROERR      IF SO, CAN'T BE FORGOTTON
    LDD ,--X        GET ADDRESS OF PREVIOUS WORD
    STD HERE+3      NEW DICTIONARY START
FORG1   LDA ,-X     GET CHARACTER FROM NAME
    BPL FORG1       KEEP GOING TILL WE FIND DESCRIPTOR BYTE
    STX FREE+3      NEW FREE SPACE FOR DICTIONARY
    RTS
* WORD IS PROTECTED, CAN'T 'FORGET' IT
PROERR  LBSR    ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Protected'
* 'CREATE' - CREATE NEW WORD IN DICTIONARY
    FDB $80
    FCC 'ETAERC'
    FDB FORGET
CREATE  LDY INPTR+3     GET INPUT BUFFER POSITION
    LBSR    LOOKUP      SEE IF IT ALREADY EXISTS
    BEQ CRE1        NO, ITS OK
    LEAU    2,U     REMOVE ADDRESS OF EXISTING WORD
    LDX #REDMSG     POINT TO REDEFINITION MESSAGE
    LBSR    PMSG1       OUTPUT MESSAGE
    TFR Y,X     POINT TO WORD WE ARE RE-DEFINING
    LBSR    PWRD1       OUTPUT WORD TO GENERAL OUTPUT
CRE1    LBSR    QSKI1       ADVANCE TO NEXT NON-BLANK, SAVE POINTER
    LDA #$FF        START WITH COUNT OF -1
CRE3    LDB ,Y+     GET CHARACTER FROM WORD
    INCA            ADVANCE WORD SIZE COUNT
    LBSR    TSTERM      TERMINATOR CHARACTER
    BNE CRE3        LOOK TILL WE FIND END
    LEAY    -1,Y        BACKUP TO LAST CHAR
    STY INPTR+3     SAVE NEW BUFFER POSITION
    LDX FREE+3      GET ADDRESS OF FREE DICTIONARY SPACE
    LDB #$80        GET DEFAULT DESCRIPTOR BYTE
    STB ,X+     SAVE IN DICTIONARY
CRE2    LDB ,-Y     GET CHARACTER FROM NAME
    STB ,X+     SAVE IN DICTIONARY
    DECA            REDUCE COUNT OF NAME LENGTH
    BNE CRE2        MOVE ALL OF NAME INTO DICTIONARY
    LDD HERE+3      GET ADDRESS OF PREVIOUS ENTRY
    STD ,X++        SAVE IN DICTIONARY
    STX HERE+3      SAVE NEW STARTING ADDRESS
    STX FREE+3      SAVE NEW FREE SPACE ADDRESS
    RTS
* 'ALLOT' - ALLOCATE SOME SPACE IN THE DICTIONARY
    FCB $80
    FCC 'TOLLA'
    FDB CREATE
ALLOT   LDD FREE+3      GET ADDRESS OF FREE DICTIOANRY SPACE
    ADDD    ,U++        OFFSET BY NUMBER OF BYTES REQUESTED
    STD FREE+3      RESAVE NEW FREE POINTER
    RTS
* 'VARIABLE' - CREATE A VARIABLE
    FCB $80
    FCC 'ELBAIRAV'
    FDB ALLOT
VAR BSR CREATE      CREATE THE VARIABLE NAME
    LDA #$BD        GET A 'JSR' EXTENDED INSTRUCTION
    STA ,X+     INSERT INTO DICTIONARY
    LDD #VARIAB     GET ADDRESS OF VARIABLE SUBROUTINE
    STD ,X++        INSERT INTO DICTIONARY
    LDD ,U++        GET DEFAULT VARIABLE VALUE
    STD ,X++        SAVE INTO DICTIONARY
    STX FREE+3      SET NEW FREE POINTER
    RTS
* ';' - END A COLON DEFINITION, TERMINATE COMPILING
    FCB $83
    FCC ';'
    FDB VAR
SEMI    LDD -2,X        GET LAST INSTRUCTION COMPLIED
    CMPD    #$3606      IS IT 'PSHU A,B'?
    BEQ SEMI1       IF SO, ITS OK
    LDA -3,X        GET INSTRUCTION FROM DICTIONARY
    CMPA    #$BD        IS IT 'JSR >'?
    BNE SEMI1       NO, ITS OK
* CONVERT 'JSR' FOLLOWED BY 'RTS' TO SIMPLE 'JMP'
    LDA #$7E        GET 'JMP >' INSTRUCTION
    STA -3,X        SAVE IN DICTIONARY
    BRA SEMI2       TERMINATE COMPILING
SEMI1   LDA #$39        GET 'RTS' INSTRUCTION
    STA ,X+     SAVE IN DICTIONARY
SEMI2   STX FREE+3      RESAVE FREE POINTER
    JMP QUIT        RE-ENTER COMMAND INTERPRETER
* ':' - COLON DEFINITION, BEGIN COMPLIING
    FCB $84
    FCC ':'
    FDB SEMI
COLON   JSR CREATE      CREATE NEW WORD
COL1    JSR QSKIP       ADVANCE TO NON-BLANK
    BNE COL11       NOT END OF LINE, ITS OK
    JSR READ        READ ANOTHER LINE (NO SEMICOLON YET)
    BRA COL1        AND CONTINUE SCANNING
*WE HAVE A WORD, COMPILE INTO PRESENT DEFINITION
COL11   LBSR    LOOKUP      LOOKUP WORD
    BNE COL2        FOUND, WE HAVE IT
    JSR NUMBER      TRY IT AS A NUMBER
    LDD ,U++        GET FLAG
    LBEQ    LOKERR      NUMBER FAILED, ITS AN ERROR
* NUMBER TO BE COMPILED INTO DICTIONARY
COL12   BSR BRCL        COMPILE LITERAL VALUE
    BRA COL1        AND KEEP SCANNING
* WORD TO BE COMPILED INTO DICTIONARY
COL2    BITA    #$04        IS IT OK TO COMPILE?
    BNE INTERR      NO, FORCE ERROR
    BITA    #1      DOES IT EXECUTE ON COMPILATION?
    BEQ COL3        NO, NORMAL WORD
    STU TEMP        SAVE STACK POINTER
    LDX FREE+3      GET FREE ADRESS FOR EC FUNCTIONS
    JSR [,U++]      EXECUTE WORD
    CMPU    TEMP        DID IT LEAVE EXACTLY ONE WORD ON THE STACK?
    BNE COL1        NO, CONTINUE SCANNING
    BRA COL12       SPECIAL CASE, COMPILE WORD AS LITERAL
* NORMAL WORD, COMPILE AS WORD CALL
COL3    BSR COMP1       COMPILE CALL TO WORD
    BRA COL1        AND KEEP SCANNING
* NON-COMPILE WORD ENCOUNTERED
INTERR  LBSR    ERROR       GENERATE ERROR MESAGE
    FCCZ    'Cannot Compile'
* '[CR]' - COMPILE A RETURN INSTRUCTION
    FCB $82
    FCC ']RC['
    FDB COLON
BRCR    LDX FREE+3      GET FREE ADDRESS
    LDB #$39        GET 'RTS' INSTRUCTION
    BRA BRC11       PLACE INTO DICTIONATY
* '[CL]' - COMPILE A LITERAL VALUE
    FCB $82
    FCC ']LC['
    FDB BRCR
BRCL    LDX FREE+3      GET FREE ADDRES
    LDA #$CC        GET 'LDD #' INSTRUCTION
    STA ,X+     PLACE IN DICTIONARY
    LDD ,U++        GET DATA VALUE
    STD ,X++        PLACE IN DICTIONAT
    LDD #$3606      GET 'PSHU A,B' INSTRUCTION
    BRA COMP3       PLACE IN DICTIONARY
* '[CW]' - COMPILE CALL TO A WORD INTO THE DICTIONARY
    FCB $82
    FCC ']WC['
    FDB BRCL
BRCW    LDX FREE+3      GET FREE ADDRESS
    BRA COMP1       COMPILE INTO DICTIONRY
* '[C2]' - COMPILE A TWO BYTE (WORD) VALUE INTO THE DICTIONARY
    FCB $82
    FCC ']2C['
    FDB BRCW
BRC2    LDX FREE+3      GET FREE ADDRESS
    BRA COMP3       COMPILE TWO BYTE VALUE
* '[C1]' - COMPILE A SINGLE BYTE VALUE INTO THE DICTIONARY
    FCB $82
    FCC ']1C['
    FDB BRC2
BRC1    LDX FREE+3      GET FREE ADDRESS
    LDD ,U++        GET VALUE TO COMPILE
BRC11   STB ,X+     PLACE IN DICTIONARY
    BRA COMP4       RESAVE FREE POINTER
* '[FC]' - FORCE COMPILATION OF NEXT WORD, EVEN IF NORMALY AUTO-EXEC
    FCB $83
    FCC ']CF['
    FDB BRC1
BRCF    JSR TICK        LOOKUP WORD ADDRESS
    BITA    #$04        CAN IT BE COMPILED?
    BNE INTERR      NO, GET UPSET
* COMPILE CALL TO A WORD INTO DICTIONARY
COMP1   LDA #$BD        GET 'JSR >' INSTRUCTION
    STA ,X+     WRITE TO DICTIONARY
COMP2   LDD ,U++        GET VALUE FROM DATE STACK
COMP3   STD ,X++        WRITE TO DICTIONARY
COMP4   STX FREE+3      RESAVE FREE POINTER
    RTS
* '[NI]' - CAUSE LAST (OR CURRENTLY) COMPILED WORD TO BE NON-INTERACTIVE
    FCB $81
    FCC ']IN['
    FDB BRCF
BRNI    LDB #2      GET [NI] BIT
    BRA SETBIT      SET BIT IN DESCRIPTOR BYTE
* '[NC]' - CAUSE LAST (OR CURRENTLY) COMPILED WORD TO BE NON-COMPILING
    FCB $81
    FCC ']CN['
    FDB BRNI
BRNC    LDB #4      GET [NC] BIT
    BRA SETBIT      SET BIT IN DESCRIPTOR BYTE
* '[EC]' - CAUSE LAST (OR CURRENTLY) COMPILED WORD TO EXECUTE WHEN COMPILED
    FCB $81
    FCC ']CE['
    FDB BRNC
BREC    LDB #1      GET [EC] BIT
* SET A BIT IN THE DESCRIPTOR BYTE FOR LAST WORD IN DICTIONARY
SETBIT  LDY HERE+3      GET ADDRESS OF LAST WORD IN DICTIONARY
    LEAY    -2,Y        BACKUP TO NAME
SETB1   LDA ,-Y     GET CHAR FROM NAME
    BPL SETB1       KEEP READING TILL WE GET DESCRIPTOR BYTE
    PSHS    B       SAVE BIT TO ADD
    ORA ,S+     INCLUDE BIT IN DESCRIPTOR BYTE
    STA ,Y      RESAVE NEW DESCRIPTOR
    RTS
* 'EXEC>' - COMPILE JUMP TO REMAINDER OF THIS WORD INTO NEW WORD
    FCB $82
    FCC '>CEXE'
    FDB BREC
DOES    LDX FREE+3      GET ADDRESS OF FREE DICTIONARY
    LDA #$7E        GET 'JMP >' INSTRUCTION
    STA ,X+     SAVE IN DICTIONARY
    PULS    A,B     GET ADDRESS OF REMAINDER OF THIS WORD
    BRA COMP3       COMPILE INTO DICTIONARY
* '(' - BRACE, START OF COMMENT
    FCB $81
    FCC '('
    FDB DOES
BRACE   LDY INPTR+3     GET INPUT POINTER
BRAC1   LDA ,Y+     GET DATA FROM BUFFER
    BEQ BRAC3       END OF LINE
    CMPA    #')'        IS IT CLOSING BRACE?
    BEQ BRAC2       YES, EXIT
    CMPA    #'('        IS IT NESTED OPENING BRACE?
    BNE BRAC1       NO, ITS OK
    BSR BRAC1       RECURSE
    BRA BRAC1       AND KEEP LOOKING
* END OF LINE, WITH NO CLOSING COMMENT
BRAC3   JSR READ        READ ANOTHER LINE
    BRA BRACE       AND KEEP LOOKING
BRAC2   STY INPTR+3     RESAVE INPUT POINTER
    RTS
* 'LEAVE' - EXIT INNERMOST DO LOOP
    FCB $82
    FCC 'EVAEL'
    FDB BRACE
LEAVE   LDD 4,S     GET LOOP LIMIT
    STD 2,S     SET INDEX TO SAME VALUE
    RTS
* '+LOOP' - LOOP WITH VALUE TO ADD
    FCB $83
    FCC 'POOL+'
    FDB LEAVE
PLOOP   PULU    A       GET STRUCTURE TYPE
    CMPA    #$81        IS IT DO LOOP?
    BNE NSTERR      NO, NESTING ERROR
    LDD #$EC62      'LDD 2,S'
    STD ,X++        COMPILE INTO DICTIONARY
    LDD #$E3C1      'ADDD ,U++'
    STD ,X++        COMPILE
    LDA #$ED        'STD 2,S'
    STA ,X+     COMPILE
    BRA LOOP1       END TERMINATE NORMALLY
* 'LOOP' - NORMAL DO LOOP
    FCB $83
    FCC 'POOL'
    FDB PLOOP
LOOP    PULU    A       GET STRUCTURE TYPE
    CMPA    #$81        IS IT DO LOOP?
    BNE NSTERR      NO, NESTING ERROR
    LDD #$EC62      'LDD 2,S'
    STD ,X++        PLACE IN DICTIONARY
    LDD #$C300      'ADDD #1'
    STD ,X++        PLACE IN DICTIONARY
    LDD #$01ED      'STD 2,S'
    STD ,X++        PLACE IN DICTIONARY
LOOP1   LDD #$6210      < CATCHUP > (POSTBYTE FOR STD, PREFIX FOR CMPD)
    STD ,X++        SAVE IN DICTIONARY
    LDD #$A3E4      'CMPD ,S'
    STD ,X++        COMPILE
    LDD #$1025      'LBLO'
    LBSR    UNT1        CALCULATE OFFSET VALUE AND COMPILE
    LDD #$3264      'LEAS 4,S'
    STD ,X++        COMPILE
COMRET  STX FREE+3      SAVE NEW FREE POINTER
    RTS
* 'K' - THIRD INDEX VALUE FOR DO LOOP
    FCB $80
    FCC 'K'
    FDB LOOP
K   LDD 12,S        GET INDEX VALUE
    BRA IJK     SAVE IT
* 'J' - SECOND INDEV VALUE FOR DO LOOP
    FCB $80
    FCC 'J'
    FDB K
J   LDD 8,S     GET INDEX VALUE
    BRA IJK     SAVE IT
* 'I' FIRST INDEX VALUE FOR DO LOOP
    FCB $80
    FCC 'I'
    FDB J
I   LDD 4,S     GET INDEX VALUE
IJK STD ,--U        SAVE ON STACK
    RTS
* STRUCTURE IS NESTED IMPROPERLY
NSTERR  LBSR    ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Improper nesting'
* 'DO' - START OF DO LOOP CONSTRUCT
    FCB $83
    FCC 'OD'
    FDB I
DO  LDA #$BD        GET 'JSR >' INSTRUCTION
    STA ,X+     COMPILE INTO DICTIONARY
    LDY #TOR        ADDRESS OF '>R' WORD
    STY ,X++        COMPILE INTO DICT
    STA ,X+     AND ANOTHER 'JSR >'
    STY ,X++        FOR ANOTHER '>R'
    LDA #$81        INDICATE DO LOOP
    PSHU    A,X     SAVE PGM COUNTER ETC
    BRA COMRET      RESAVE FREE POINTER
* 'FOREVER' - BEGIN LOOP FOREVER
    FCB $83
    FCC 'REVEROF'
    FDB DO
FOREVE  PULU    A,Y     GET LOOP CONSTRUCT IDENTIFIER
    CMPA    #$80        WAS IT A BEGIN LOOP?
    BNE NSTERR      NO, IMPROPER NESTING
    LDA #$7E        'JMP >' INSTRUCTION
    STA ,X+     PLACE IN DICTIONARY
    STY ,X++        INCLUDE ADDRESS TO LOOP TO
    BRA COMRET      RESAVE FREE POINTER
* 'UNTIL' - CONDITIONAL BEGIN LOOP
    FCB $83
    FCC 'LITNU'
    FDB FOREVE
UNTIL   PULU    A       GET STRUCTURE IDENTIFIER
    CMPA    #$80        IS IT A BEGIN LOOP?
    BNE NSTERR      NO, BAD NESTING
    LDD #$ECC1      'LDD ,U++'
    STD ,X++        SAVE IN DICTIONARY
    LDD #$1027      'LBEQ'
* COMPILE LONG BRANCH, AND CALCULATE OFFSET FROM ADDRESS ON STACK
UNT1    STD ,X++        SAVE IN DICTIONARY
    LEAX    2,X     GET CURRENT ADDRESS
    PSHS    X       SAVE ON STACK
    PULU    A,B     GET ADDRESS TO JUMP TO
    SUBD    ,S++        CALCULATE OFFSET
    STD -2,X        COMPILE INTO DICTIONARY
COMR1   LBRA    COMRET      RESAVE FREE POINTER
* 'WHILE' - CONDITIONAL BEGIN LOOP
    FCB $83
    FCC 'ELIHW'
    FDB UNTIL
WHILE   PULU    A       GET STRUCTURE IDENTIFIER
    CMPA    #$80        IS IT A BEGIN LOOP?
    BNE NSTERR      NO, IMPROPER NESTING
    LDD #$ECC1      'LDD ,U++'
    STD ,X++        COMPILE INTO DICTIONARY
    LDD #$1026      'LBNE'
    BRA UNT1        COMPILE INTO DICT WITH OFFSET
* 'BEGIN' - START A BEGIN LOOP
    FCB $83
    FCC 'NIGEB'
    FDB WHILE
BEGIN   LDA #$80        BEGIN LOOP IDENTIFIER
    PSHU    A,X     SAVE IT AND CURRENT POSITION
    RTS
* 'ENDIF' - END AN IF STATEMENT
    FCB $83
    FCC 'FIDNE'
    FDB BEGIN
ENDIF   PULU    A       GET STRUCTURE IDENTIFIER
    CMPA    #$82        IS IT 'IF'?
    LBNE    NSTERR      NO, BAD NESTING
    LDY ,U      GET ADDRESS
    TFR X,D     GET CURRENT FREE ADDRESS
    SUBD    ,U++        CALCULATE OFFSET
    STD -2,Y        SAVE IN BRANCH OPERAND
    RTS
* 'ELSE' - ELSE CLAUSE TO AN IF STATEMENT
    FCB $83
    FCC 'ESLE'
    FDB ENDIF
ELSE    LDA #$16        'LBRA'
    STA ,X+     COMPILE INTO DICTIONARY
    LEAX    2,X     SKIP TO NEXT FREE
    PSHS    X       SAVE ADDRESS
    BSR ENDIF       COMPILE IN BRANCH
    PULS    X       RESTORE ADDRESS
    BRA IF1     SET UP NEW IF JUMPS
* 'IF' - IF CONDITION
    FCB $83
    FCC 'FI'
    FDB ELSE
IF  LDD #$ECC1      'LDD ,U++'
    STD ,X++        COMPILE
    LDD #$1027      'LBEQ'
    STD ,X++        COMPILE
    LEAX    2,X     ADVANCE TO FREE
IF1 LDA #$82        INDICATE IF STRUCTURE
    PSHU    A,X     SAVE WITH ADDRESS ON STACK
COMR2   LBRA    COMRET      RESAVE FREE POINTER
* '."' DISPLAY MESSAGE ON TERMINAL
    FCB $83
    FCC '".'
    FDB IF
DOTQ    BSR QUOTE       COMPILE STRING
    LDA #$BD        'JSR >'
    STA ,X+     COMPILE INTO DICT
    LDD #PMSG       DISPLAY MESSAGE
    STD ,X++        COMPILE INTO DICT
    BRA COMR2       RESAVE FREE POINTER
* '"' - COMPILE STRING INTO DICTIONARY
    FCB $83
    FCC '"'
    FDB DOTQ
QUOTE   LDA #$8D        'BSR' INSTRUCTION
    STA ,X++        COMPILE INTO DICT
    JSR QSKIP       ADVANCE TO NON-BLANK
    PSHS    X       SAVE POINTER
QUO1    LDA ,Y+     GET DATA FROM INPUT BUFFER
    BEQ UNTERR      END OF LINE, ERROR
    CMPA    #'"'        IS IT CLOSING QUOTE?
    BEQ QUO2        YES, EXIT
    STA ,X+     SAVE IN STRING
    BRA QUO1        AND KEEP PROCESSING
QUO2    STY INPTR+3     SAVE NEW INPUT BUFFER POINTER
    CLR ,X+     INDICATE END OF STRING
    LDY ,S      GET ADDRESS OF BSR OPERAND
    TFR X,D     GET CURRENT ADDRESS
    SUBD    ,S++        CALCULATE OFFSET FOR BSR
    STB -1,Y        SAVE IN OPERAND
    LDA #$BD        'JSR >'
    STA ,X+     COMPILE INTO DICT
    LDD #FROMR      GET '>R' ADDRESS
    STD ,X++        COMPILE
    BRA COMR2       RESAVE FREE POINTER
* UNTERMINATED STRING
UNTERR  LBSR    ERROR       GENERATE ERROR MESSAGE
    FCCZ    'Unterminated'
* '0' - QUICKER ZERO
    FCB $80
    FCC '0'
    FDB QUOTE
ZERO    CLRA            ZERO HIGH BYTE
    CLRB            ZERO LOW BYTE
    STD ,--U        SAVE ON DATA STACK
    RTS
* '1' - QUICKER ONE
    FCB $80
    FCC '1'
    FDB ZERO
ONE LDD #1      GET A VALUE OF ONE
    STD ,--U        SAVE ON STACK
    RTS
*
* VARIABLES
*
* '(OUT)' - ADDRESS OF GENERAL OUTPUT DRIVER
    FCB $80
    FCC ')TUO('
    FDB ONE
DISP    JSR VARIAB      VARIABLE SUBROUTINE
    FDB DOLOUT      DEFAULT IS '$OUT'
* '(IN)' - ADDRESS OF GENERAL INPUT DRIVER
    FCB $80
    FCC ')NI('
    FDB DISP
INPT    JSR VARIAB      VARIABLE SUBROUTINE
    FDB DOLIN       DEFAULT IS '$IN'
* '(GO)' - ADDRESS OF WORD TO EXECUTE AT STARTUP
    FCB $80
    FCC ')OG('
    FDB INPT
BOOT    JSR VARIAB      VARIABLE SUBROUTINE
    FDB QUIT        DEFUALT IS 'QUIT'
* '>IN' - POINTER TO POSITION IN INPUT BUFFER
    FCB $80
    FCC 'NI>'
    FDB BOOT
INPTR   JSR VARIAB      VARIABLE SUBROUTINE
    FDB INPBUF      DEFAULT IS START OF BUFFER
* 'BASE' - CURRENT NUMBER CONVERSION BASE
    FCB $80
    FCC 'ESAB'
    FDB INPTR
BASE    JSR VARIAB      VARIABLE SUBROUTINE
    FDB 10      DEFAULT IS BASE 10
* 'FREE' - ADDRESS OF FREE MEMORY FOLLOWING DICTIONARY
    FCB $80
    FCC 'EERF'
    FDB BASE
FREE    JSR VARIAB      VARIABLE SUBROUTINE
    FDB USRSPC      DEFAULT IS END OF DICTIONARY
* 'HERE' - ADDRESS OF LAST WORD IN DICTIONARY
    FCB $80
    FCC 'EREH'
    FDB FREE
HERE    JSR VARIAB      VARIABLE SUBROUTINE
    FDB HERE        DEFUALT IS ITSELF
* DICTIONARY GROWS FROM HERE
USRSPC  EQU *
