Power-Programmierung/CD1.mdf/forth/compiler/eforth/eforth.old

Text File | 1990-07-26 | 47KB | 2,100 lines

TITLE 8086 eForth
NAME eForth
PAGE 62,132    ;62 lines per page, 132 characters per line
.SALL        ;Suppress listing of macro expressions
.XCREF        ;Suppress generating cross-references

;====================================================================
;
;    eForth 1.0 by Bill Muench and C. H. Ting, 1990
;    Much of the code is derived from the following two sources:
;        8086 figForth by Thomas Newman, 1981 and Joe smith, 1983
;        bFORTH by Bill Muench, 1990
;
;    The goal of this implementation is to provide a simple eForth Model
;    which can be ported easily to many 8, 16, 24 and 32 bit CPU's.
;    The following attributes make it suitable for CPU's of the '90:
;
;        small machine dependent kernel and portable high level code
;        source code in the MASM format
;        direct threaded code
;        separated code and name dictionaries
;        simple vectored terminal and file interface to host computer
;        aligned with the proposed ANS Forth Standard
;        easy upgrade path to optimize for specific CPU
;
;    You are invited to implement this Model on your favorite CPU and
;    contribute it to the eForth Library for public use. You may use
;    a portable implementation to advertise more sophisticated and
;    optimized version for commercial purposes. However, you are
;    expected to implement the Model faithfully. The eForth Working
;    Group reserves the right to reject implementation which deviates
;    significantly from this Model.
;
;    As the ANS Forth Standard is still evolving, this Model will
;    change accordingly. Implementations must state clearly the
;    version number of the Model being tracked.
;
;    Representing the eForth Working Group in the Silicon Valley FIG Chapter.
;    Contributions must be sent to:
;
;        Dr. C. H. Ting
;        156 14th Avenue
;        San Mateo, CA  94402
;        [phone]
;
;===================================================================

;; Version control

VER        EQU    1            ;major release version
EXT        EQU    0            ;minor extension

;; Memory allocation

EM        EQU    4000H            ;top of memory
US        EQU    128            ;user area size in bytes
RTS        EQU    256            ;return stack/TIB size

UPP        EQU    EM-US            ;start of user area (UP0)
RPP        EQU    UPP-2            ;start of return stack (RP0)
TIBB        EQU    UPP-RTS            ;terminal input buffer (TIB)
SPP        EQU    RPP-RTS            ;start of data stack (SP0)

NAMEE        EQU    3C00H            ;name dictionary
COLDD        EQU    0100H            ;cold start vector
CODEE        EQU    COLDD+US        ;code dictionary

;; Constants and equates

FALSS        EQU    0            ;false flag
TRUEE        EQU    -1            ;true flag

IMEDD        EQU    80H            ;lexicon immediate bit
COMPO        EQU    40H            ;lexicon compile only bit
MASKK        EQU    7F1FH            ;lexicon bit mask

CELLL        EQU    2            ;size of a cell
BASEE        EQU    10            ;default radix
VOCSS        EQU    8            ;depth of vocabulary stack

BKSPP        EQU    8            ;back space
LF        EQU    10            ;line feed
CRR        EQU    13            ;carriage return
ERR        EQU    27            ;error escape
TIC        EQU    39            ;tick

CALLL        EQU    0E890H            ;NOP CALL opcodes

;; Initialize assembly variables

_LINK    = 0                    ;force a null link
_NAME    = NAMEE                    ;name space pointer
_CODE    = CODEE                    ;save code space pointer
_USER    = 4*CELLL                ;first user variable offset

;; Define assembly macros

;    Compile a eForth name field
;    Lay down the header backwards in memory

$NAME    MACRO    LBYTE,NAME,LABEL,TACKY
    EVEN                    ;;fill NOP to cell boundary
LABEL:                        ;;label to be used in definitions
    _CODE    = $                ;;save code pointer for token
    _NAME    = _NAME-(LBYTE AND 1EH)-CELLL*3    ;;new header on cell boundary.
ORG     _NAME
    DW     _CODE                ;;token feild
    DW     _LINK                ;;link field
    _LINK    = $                ;;next link points to name field
    DB    LBYTE                ;;length
    IFNB    <TACKY>
    DB    "&NAME"                ;;name contains a '
    ELSE
    DB    '&NAME'                ;;name may contain a "
    ENDIF
ORG     _CODE                    ;;restore code pointer
    ENDM

;    Compile a code definition header.

$CODE    MACRO    ONE,TWO,THREE,FOUR
    $NAME    ONE,TWO,THREE,FOUR
    ENDM

;    Compile a colon definition header.

$COLON    MACRO    ONE,TWO,THREE,FOUR
    $NAME    ONE,TWO,THREE,FOUR
    NOP                    ;;align to cell boundary
    CALL    DOLST                ;;include CALL doLIST
    ENDM

;    Compile a user variable header.

$USER    MACRO    ONE,TWO,THREE,FOUR
    $NAME    ONE,TWO,THREE,FOUR
    NOP                    ;;align to cell boundary
    CALL    DOLST                ;;include CALL doLIST
    DW    DOUSE                ;;followed by doUSER
    DW    _USER                ;;and the user area offset
    _USER = _USER+CELLL            ;;update user area offset
    ENDM

;    Assemble inline direct threaded code ending.

$NEXT    MACRO
    LODSW                    ;;read code address of next word into AX
    JMP    AX                ;;jump directly to the code address
    ENDM

;; Main entry points and COLD start data

MAIN    SEGMENT
    ASSUME    CS:MAIN,DS:MAIN,ES:MAIN,SS:MAIN

ORG    COLDD                    ;beginning of cold boot area

ORIG:        MOV    AX,CS
        MOV    DS,AX            ;all in one segment
        CLI                ;disable interrupt for old 808x CPU bug
        MOV    SS,AX
        MOV    SP,SPP            ;initialize SP
        STI
        MOV    BP,RPP            ;initialize RP
        MOV    AL,23H            ;^C interrupt INT23
        MOV    DX,OFFSET CTRLC
        MOV    AH,25H            ;set ^C address
        INT    21H
        CLD                ;SI gets incremented
        MOV    SI,OFFSET COLD1
        $NEXT                ;to high level cold start

CTRLC:        IRET                ;just return from ^C interrupt INT 23H

; COLD start moves the following to USER variables.
; MUST BE IN SAME ORDER AS USER VARIABLES

EVEN                        ;align to cell boundary

UZERO:        DW    4 DUP (0)        ;reserved space in user area
        DW    SPP            ;SP0
        DW    RPP            ;RP0
        DW    QRX            ;'?KEY
        DW    STOTX            ;'EMIT
        DW    ACCEP            ;'EXPECT
        DW    KTAP            ;'TAP
        DW    STOTX            ;'ECHO
        DW    DOTOK            ;'PROMPT
        DW    BASEE            ;BASE
        DW    0            ;tmp
        DW    0            ;SPAN
        DW    0            ;>IN
        DW    0            ;#TIB
        DW    TIBB            ;TIB
        DW    0            ;CSP
        DW    INTER            ;'EVAL
        DW    NUMBQ            ;'NUMBER
        DW    0            ;HLD
        DW    0            ;HANDLER
        DW    UPP+V4TH-UZERO        ;CONTEXT point to FORTH
        DW    VOCSS DUP (0)        ;vocabulary stack
        DW    UPP+V4TH-UZERO        ;CURRENT point to FORTH
        DW    V4TH            ;voc-link
        DW    CTOP            ;CP
        DW    NTOP            ;NP
        DW    LASTN            ;LAST

V4TH:        DW    LASTN,0            ;simple FORTH vocabulary
        DW    6 DUP (0)        ;3 more vocabularies

ULAST:

;; The kernel

ORG    CODEE                    ;beginning of the code dictionary

;=C   doLIT    ( -- w )
;        Push an inline literal.

        $CODE    COMPO+5,doLIT,DOLIT
        LODSW
        PUSH    AX
        $NEXT

;=C   doLIST    ( a -- )
;        Process colon list.

        $CODE    COMPO+6,doLIST,DOLST
        XCHG    BP,SP            ;exchange the return and data stack pointers
        PUSH    SI            ;push on return stack
        XCHG    BP,SP            ;restore the pointers
        POP    SI            ;new list address
        $NEXT

;=C   next    ( -- )
;        Run time code for the single index loop.

        $CODE    COMPO+4,next,DONXT
        SUB    WORD PTR [BP],1        ;decrement the index
        JC    NEXT1            ;?decrement below 0
        MOV    SI,0[SI]        ;no, branch back again
        $NEXT
NEXT1:        INC    BP            ;yes, pop the index
        INC    BP
        INC    SI            ;continue past the branch offset
        INC    SI
        $NEXT

;=C   ?branch    ( f -- )
;        Branch if flag is zero.

        $CODE    COMPO+7,?branch,QBRAN
        POP    BX            ;pop flag
        OR    BX,BX            ;?flag=0
        JZ    BRAN1            ;yes, so branch
        INC    SI            ;point IP to next word
        INC    SI
        $NEXT
BRAN1:        MOV    SI,0[SI]        ;IP:=(IP)
        $NEXT

;=C   branch    ( -- )
;        Branch to an inline address.

        $CODE    COMPO+6,branch,BRAN
        MOV    SI,0[SI]        ;IP:=(IP)
        $NEXT

;=C   BYE    ( -- )
;        Exit eForth.

        $CODE    3,BYE,BYE
        INT    20H            ;MS-DOS terminate process

;=C   EXECUTE    ( ca -- )
;        Executes the word at ca.

        $CODE    7,EXECUTE,EXECU
        POP    BX
        JMP    BX            ;jump to the code address

;=C   EXIT    ( -- )
;        Terminate current colon word.

        $CODE    4,EXIT,EXIT
        MOV    SI,[BP]            ;pop return address
        INC    BP            ;adjust RP
        INC    BP
        $NEXT

;=C   !        ( w a -- )
;        Pop the data stack to memory.

        $CODE    1,!!!!,STORE
        POP    BX
        POP    0[BX]
        $NEXT

;=C   @        ( a -- w )
;        Push memory location to the data stack.

        $CODE    1,@,AT
        POP    BX
        PUSH    0[BX]
        $NEXT

;=C   C!    ( c b -- )
;        Pop the data stack to byte memory.

        $CODE    2,C!!!!,CSTOR
        POP    BX
        POP    AX
        MOV    0[BX],AL
        $NEXT

;=C   C@    ( b -- c )
;        Push byte memory location to the data stack.

        $CODE    2,C@,CAT
        POP    BX
        XOR    AX,AX            ;AX=0 zero the hi byte
        MOV    AL,0[BX]
        PUSH    AX
        $NEXT

;=C   RP@    ( -- a )
;        Push the current RP to the data stack.

        $CODE    3,RP@,RPAT
        PUSH    BP
        $NEXT

;=C   RP!    ( a -- )
;        Set the return stack pointer.

        $CODE    COMPO+3,RP!!!!,RPSTO
        POP    BP
        $NEXT

;=C   R>    ( -- w )
;        Pop the return stack to the data stack.

        $CODE    COMPO+2,R!!!>,RFROM
        PUSH    0[BP]
        INC    BP            ;adjust RP
        INC    BP
        $NEXT

;=C   R@    ( -- w )
;        Copy top of return stack to the data stack.

        $CODE    2,R@,RAT
        PUSH    0[BP]
        $NEXT

;=C   >R    ( w -- )
;        Push the data stack to the return stack.

        $CODE    COMPO+2,!!!>R,TOR
        DEC    BP            ;adjust RP
        DEC    BP
        POP    0[BP]            ;push
        $NEXT

;=C   SP@    ( -- a )
;        Push the current data stack pointer.

        $CODE    3,SP@,SPAT
        MOV    BX,SP            ;use BX to index the data stack
        PUSH    BX
        $NEXT

;=C   SP!    ( a -- )
;        Set the data stack pointer.

        $CODE    3,SP!!!!,SPSTO
        POP    SP
        $NEXT

;=C   DROP    ( w -- )
;        Discard top stack item.

        $CODE    4,DROP,DROP
        INC    SP            ;adjust SP
        INC    SP
        $NEXT

;=C   DUP    ( w -- w w )
;        Duplicate the top stack item.

        $CODE    3,DUP,DUPP
        MOV    BX,SP            ;use BX to index the data stack
        PUSH    0[BX]
        $NEXT

;=C   SWAP    ( w1 w2 -- w2 w1 )
;        Exchange top two stack items.

        $CODE    4,SWAP,SWAP
        POP    BX
        POP    AX
        PUSH    BX
        PUSH    AX
        $NEXT

;=C   OVER    ( w1 w2 -- w1 w2 w1 )
;        Copy second stack item to top.

        $CODE    4,OVER,OVER
        MOV    BX,SP            ;use BX to index the stack
        PUSH    2[BX]
        $NEXT

;=C   0<    ( n -- t )
;        Return true if n is negative.

        $CODE    2,0!!!<,ZLESS
        POP    AX
        CWD                ;sign extend
        PUSH    DX
        $NEXT

;=C   AND    ( w w -- w )
;        Bitwise AND.

        $CODE    3,AND,ANDD
        POP    BX
        POP    AX
        AND    BX,AX
        PUSH    BX
        $NEXT

;=C   OR    ( w w -- w )
;        Bitwise OR.

        $CODE    2,OR,ORR
        POP    BX
        POP    AX
        OR    BX,AX
        PUSH    BX
        $NEXT

;=C   XOR    ( w w -- w )
;        Bitwise exclusive OR.

        $CODE    3,XOR,XORR
        POP    BX
        POP    AX
        XOR    BX,AX
        PUSH    BX
        $NEXT

;=C   UM+    ( u u -- udsum )
;        Add two unsigned single numbers and return a double sum.

        $CODE    3,UM+,UPLUS
        XOR    CX,CX            ;CX=0 initial carry flag
        POP    BX
        POP    AX
        ADD    AX,BX
        RCL    CX,1            ;get carry
        PUSH    AX            ;push sum
        PUSH    CX            ;push carry
        $NEXT

;; Device I/O

;=C   ?RX    ( -- c T | F )
;        Return input character and true, or a false if no input.

        $CODE    3,?RX,QRX
        XOR    BX,BX            ;BX=0 setup for false flag
        MOV    DL,0FFH            ;input command
        MOV    AH,6            ;MS-DOS Direct Console I/O
        INT    21H
        JZ    DQKE3            ;?key ready
        OR    AL,AL            ;AL=0 if extended char
        JNZ    DQKE1            ;?extended character code
        INT    21H
        MOV    BH,AL            ;extended code in msb
        JMP    DQKE2
DQKE1:        MOV    BL,AL
DQKE2:        PUSH    BX            ;save character
        MOV    BX,TRUEE        ;true flag
DQKE3:        PUSH    BX
        $NEXT

;=C   TX!    ( c -- )
;        Send character c to the output device.

        $CODE    3,TX!!!!,STOTX
        POP    DX            ;char in DL
        CMP    DL,0FFH            ;0FFH is interpreted as input
        JNZ    EMIT1            ;do NOT allow input
        MOV    DL,32            ;change to blank
EMIT1:        MOV    AH,6            ;MS-DOS Direct Console I/O
        INT    021H            ;display character
        $NEXT

;=C   !IO    ( -- )
;        Initialize the serial I/O devices.

        $CODE    3,!!!!IO,STOIO
        $NEXT

;; User variables and system variables

;=:   doVAR    ( -- a )
;        Run time routine of variable and CREATE area.

        $COLON    COMPO+5,doVAR,DOVAR
        DW    RFROM,EXIT

;=:   UP    ( -- a )
;        Pointer to the user area.

        $COLON    2,UP,UP
        DW    DOVAR
        DW    UPP

;=:   doUSER    ( -- a )
;        Run time routine of user variables.

        $COLON    COMPO+6,doUSER,DOUSE
        DW    RFROM,AT,UP,AT,PLUS,EXIT

;=U   SP0    ( -- a )
;        Pointer to bottom of the data stack.

        $USER    3,SP0,SZERO

;=U   RP0    ( -- a )
;        Pointer to bottom of the return stack.

        $USER    3,RP0,RZERO

;=U   '?KEY    ( -- a )
;        Execution vector of ?KEY.

        $USER    5,!!!'?KEY,TQKEY,TICKY

;=U   'eEMIT    ( -- a )
;        Execution vector of EMIT.

        $USER    5,!!!'EMIT,TEMIT,TICKY

;=U   'EXPECT    ( -- a )
;        Execution vector of EXPECT.

        $USER    7,!!!'EXPECT,TEXPE,TICKY

;=U   'TAP    ( -- a )
;        Execution vector of TAP.

        $USER    4,!!!'TAP,TTAP,TICKY

;=U   'ECHO    ( -- a )
;        Execution vector of ECHO.

        $USER    5,!!!'ECHO,TECHO,TICKY

;=U   'PROMPT    ( -- a )
;        Execution vector of PROMPT.

        $USER    7,!!!'PROMPT,TPROM,TICKY

;=U   BASE    ( -- a )
;        Storage of the radix base for numeric I/O.

        $USER    4,BASE,BASE

;=U   tmp    ( -- a )
;        A temporary storage location used in parse and find.

        $USER    COMPO+3,tmp,TEMP

;=U   SPAN    ( -- a )
;        Hold character count received by EXPECT.

        $USER    4,SPAN,SPAN

;=U   >IN    ( -- a )
;        Hold the character pointer while parsing input stream.

        $USER    3,!!!>IN,INN

;=U   #TIB    ( -- a )
;        Hold the size of the terminal input buffer.

        $USER    4,#TIB,NTIB
        _USER = _USER+CELLL        ;hold the base address of the terminal input buffer

;=U   CSP    ( -- a )
;        Hold the stack pointer for error checking.

        $USER    3,CSP,CSP

;=U   'EVAL    ( -- a )
;        Execution vector of EVAL.

        $USER    5,!!!'EVAL,TEVAL,TICKY

;=U   'NUMBER    ( -- a )
;        Execution vector of NUMBER?.

        $USER    7,!!!'NUMBER,TNUMB,TICKY

;=U   HLD    ( -- a )
;        Hold a pointer in building a numeric output string.

        $USER    3,HLD,HLD

;=U   HANDLER    ( -- a )
;        Hold the return stack pointer for error handling.

        $USER    7,HANDLER,HANDL

;=U   CONTEXT    ( -- a )
;        A area to specify vocabulary search order.

        $USER    7,CONTEXT,CNTXT
        _USER = _USER+CELLL*VOCSS    ;vocabulary stack

;=U   CURRENT    ( -- a )
;        Point to the vocabulary to be extended.

        $USER    7,CURRENT,CRRNT
        _USER = _USER+CELLL        ;vocabulary link pointer

;=U   CP    ( -- a )
;        Point to the top of the code dictionary.

        $USER    2,CP,CP

;=U   NP    ( -- a )
;        Point to the bottom of the name dictionary.

        $USER    2,NP,NP

;=U   last    ( -- a )
;        Point to the last name field in the name dictionary.

        $USER    4,LAST,LAST

;=U   VOCABS    ( -- a )???remove use label to VOCABS
;        Array of vocabulary threads.

        $USER    6,VOCABS,VOCAB

;; Common functions

;=:   ?DUP    ( w -- w w | 0 )
;        Dup tos if its is not zero.

        $COLON    4,?DUP,QDUP
        DW    DUPP
        DW    QBRAN,QDUP1
        DW    DUPP
QDUP1:        DW    EXIT

;=:   ROT    ( w1 w2 w3 -- w2 w3 w1 )
;        Rot 3rd item to top.

        $COLON    3,ROT,ROT
        DW    TOR,SWAP,RFROM,SWAP,EXIT

;=:   2DROP    ( w w -- )
;        Discard two items on stack.

        $COLON    5,2DROP,DDROP
        DW    DROP,DROP,EXIT

;=:   2DUP    ( w1 w2 -- w1 w2 w1 w2 )
;        Duplicate top two items.

        $COLON    4,2DUP,DDUP
        DW    OVER,OVER,EXIT

;=:   +        ( w w -- sum )
;        Add top two items.

        $COLON    1,+,PLUS
        DW    UPLUS,DROP,EXIT

;=:   NOT    ( w -- w )
;        One's complement of tos.

        $COLON    3,NOT,INVER
        DW    DOLIT,-1,XORR,EXIT

;=:   NEGATE    ( n -- -n )
;        Two's complement of tos.

        $COLON    6,NEGATE,NEGAT
        DW    INVER,DOLIT,1,PLUS,EXIT

;=:   DNEGATE    ( d -- -d )
;        Two's complement of top double.

        $COLON    7,DNEGATE,DNEGA
        DW    INVER,TOR,INVER
        DW    DOLIT,1,UPLUS
        DW    RFROM,PLUS,EXIT

;=:   -        ( n1 n2 -- n1-n2 )
;        Subtraction.

        $COLON    1,-,SUBB
        DW    NEGAT,PLUS,EXIT

;=:   ABS    ( n -- n )
;        Return the absolute value of n.

        $COLON    3,ABS,ABSS
        DW    DUPP,ZLESS
        DW    QBRAN,ABS1
        DW    NEGAT
ABS1:        DW    EXIT

;=:   =        ( w w -- t )
;        Return true if top two are equal.

        $COLON    1,=,EQUAL
        DW    XORR
        DW    QBRAN,EQU1
        DW    DOLIT,FALSS,EXIT
EQU1:        DW    DOLIT,TRUEE,EXIT

;=:   U<    ( u u -- t )
;        Unsigned compare of top two items.

        $COLON    2,U!!!<,ULESS
        DW    DDUP,XORR,ZLESS
        DW    QBRAN,ULES1
        DW    SWAP,DROP,ZLESS,EXIT
ULES1:        DW    SUBB,ZLESS,EXIT

;=:   <        ( n1 n2 -- t )
;        Signed compare of top two items.

        $COLON    1,!!!<,LESS
        DW    DDUP,XORR,ZLESS
        DW    QBRAN,LESS1
        DW    DROP,ZLESS,EXIT
LESS1:        DW    SUBB,ZLESS,EXIT

;=:   MAX    ( n n -- n )
;        Return the greater of two top stack items.

        $COLON    3,MAX,MAX
        DW    DDUP,LESS
        DW    QBRAN,MAX1
        DW    SWAP
MAX1:        DW    DROP,EXIT

;=:   MIN    ( n n -- n )
;        Return the smaller of top two stack items.

        $COLON    3,MIN,MIN
        DW    DDUP,SWAP,LESS
        DW    QBRAN,MIN1
        DW    SWAP
MIN1:        DW    DROP,EXIT

;=:   WITHIN    ( u ul uh -- t )
;        Return true if u is within the range of ul and uh.

        $COLON    6,WITHIN,WITHI
        DW    OVER,SUBB,TOR        ;ul<=u<uh
        DW    SUBB,RFROM,ULESS,EXIT

;; Math functions

; Divide

;=:   UM/MOD    ( udl udh un -- ur uq )
;        Unsigned divide of a double by a single. Return mod and quotient.

        $COLON    6,UM/MOD,UMMOD
        DW    DDUP,ULESS
        DW    QBRAN,UMM4
        DW    NEGAT,DOLIT,15,TOR
UMM1:        DW    TOR,DUPP,UPLUS
        DW    TOR,TOR,DUPP,UPLUS
        DW    RFROM,PLUS,DUPP
        DW    RFROM,RAT,SWAP,TOR
        DW    UPLUS,RFROM,ORR
        DW    QBRAN,UMM2
        DW    TOR,DROP,DOLIT,1,PLUS,RFROM
        DW    BRAN,UMM3
UMM2:        DW    DROP
UMM3:        DW    RFROM
        DW    DONXT,UMM1
        DW    DROP,SWAP,EXIT
UMM4:        DW    DROP,DDROP
        DW    DOLIT,-1,DUPP,EXIT

;=:   M/MOD    ( d n -- r q )
;        Signed floored divide of double by single. Return mod and quotient.

        $COLON    5,M/MOD,MSMOD
        DW    DUPP,ZLESS,DUPP,TOR
        DW    QBRAN,MMOD1
        DW    NEGAT,TOR,DNEGA,RFROM
MMOD1:        DW    TOR,DUPP,ZLESS
        DW    QBRAN,MMOD2
        DW    RAT,PLUS
MMOD2:        DW    RFROM,UMMOD,RFROM
        DW    QBRAN,MMOD3
        DW    SWAP,NEGAT,SWAP
MMOD3:        DW    EXIT

;=:   /MOD    ( n n -- r q )
;        Signed divide. Return mod and quotient.

        $COLON    4,/MOD,SLMOD
        DW    OVER,ZLESS,SWAP,MSMOD,EXIT

;=:   MOD    ( n n -- r )
;        Signed divide. Return mod only.

        $COLON    3,MOD,MODD
        DW    SLMOD,DROP,EXIT

;=:   /        ( n n -- q )
;        Signed divide. Return quotient only.

        $COLON    1,/,SLASH
        DW    SLMOD,SWAP,DROP,EXIT

; Multiply

;=:   UM*    ( u u -- ud )
;        Unsigned multiply. Return double product.

        $COLON    3,UM*,UMSTA
        DW    DOLIT,0,SWAP,DOLIT,15,TOR
UMST1:        DW    DUPP,UPLUS,TOR,TOR
        DW    DUPP,UPLUS,RFROM,PLUS,RFROM
        DW    QBRAN,UMST2
        DW    TOR,OVER,UPLUS,RFROM,PLUS
UMST2:        DW    DONXT,UMST1
        DW    ROT,DROP,EXIT

;=:   *        ( n n -- n )
;        Signed multiply. Return single product.

        $COLON    1,*,STAR
        DW    UMSTA,DROP,EXIT

;=:   M*    ( n n -- d )
;        Signed multiply. Return double product.

        $COLON    2,M*,MSTAR
        DW    DDUP,XORR,ZLESS,TOR
        DW    ABSS,SWAP,ABSS,UMSTA
        DW    RFROM
        DW    QBRAN,MSTA1
        DW    DNEGA
MSTA1:        DW    EXIT

;=:   */MOD    ( n1 n2 n3 -- r q )
;        Multiply n1 and n2, then divide by n3. Return mod and quotient.

        $COLON    5,*/MOD,SSMOD
        DW    TOR,MSTAR,RFROM,MSMOD,EXIT

;=:   */    ( n1 n2 n3 -- q )
;        Multiply n1 by n2, then divide by n3. Return quotient only.

        $COLON    2,*/,STASL
        DW    SSMOD,SWAP,DROP,EXIT

;; The text interpreter

;=:   CELL+    ( a -- a )
;        Add cell size in byte to address.

        $COLON    5,CELL+,CELLP
        DW    DOLIT,CELLL,PLUS,EXIT

;=:   CELL-    ( a -- a )
;        Subtract cell size in byte from address.

        $COLON    5,CELL-,CELLM
        DW    DOLIT,0-CELLL,PLUS,EXIT

;=:   CELLS    ( n -- n )
;        Multiply tos by cell size in bytes.

        $COLON    5,CELLS,CELLS
        DW    DOLIT,CELLL,STAR,EXIT

;=:   BL    ( -- 32 )
;        Return 32, the blank character.

        $COLON    2,BL,BLANK
        DW    DOLIT,32,EXIT

;=:   >CHAR    ( c -- c )
;        Replace non-printable character by a period.

        $COLON    5,!!!>CHAR,TCHAR
        DW    DOLIT,127,ANDD,DUPP
        DW    DOLIT,127,BLANK,WITHI
        DW    QBRAN,TCHA1
        DW    DROP,DOLIT,'.'
TCHA1:        DW    EXIT

;=:   DEPTH    ( -- n )
;        Return the depth of the data stack.

        $COLON    5,DEPTH,DEPTH
        DW    SPAT,SZERO,AT,SWAP,SUBB
        DW    DOLIT,CELLL,SLASH,EXIT

;=:   PICK    ( ... +n -- ... w )
;        Copy the nth stack item to tos.

        $COLON    4,PICK,PICK
        DW    DOLIT,1,PLUS,CELLS
        DW    SPAT,PLUS,AT,EXIT

;; Memory access

;=:   +!    ( n a -- )
;        Add n to the contents at address a.

        $COLON    2,+!!!!,PSTOR
        DW    SWAP,OVER,AT,PLUS
        DW    SWAP,STORE,EXIT

;=:   2!    ( d a -- )
;        Store the double integer to address a.

        $COLON    2,2!!!!,DSTOR
        DW    SWAP,OVER,STORE
        DW    CELLP,STORE,EXIT

;=:   2@    ( a -- d )
;        Fetch double integer from address a.

        $COLON    2,2@,DAT
        DW    DUPP,CELLP,AT
        DW    SWAP,AT,EXIT

;=:   COUNT    ( b -- b +n )
;        Return count byte of a string and add 1 to byte address.

        $COLON    5,COUNT,COUNT
        DW    DUPP,DOLIT,1,PLUS
        DW    SWAP,CAT,EXIT

;=:   HERE    ( -- a )
;        Return the top of the code dictionary.

        $COLON    4,HERE,HERE
        DW    CP,AT,EXIT

;=:   PAD    ( -- a )
;        Return the address of the text buffer above the code dictionary.

        $COLON    3,PAD,PAD
        DW    HERE,DOLIT,80,PLUS,EXIT

;=:   TIB    ( -- a )
;        Return the address of the terminal input buffer.

        $COLON    3,TIB,TIB
        DW    NTIB,CELLP,AT,EXIT

;=:   @EXECUTE    ( a -- )
;        Execute vector stored in address a.

        $COLON    8,@EXECUTE,ATEXE
        DW    AT,QDUP            ;?address or zero
        DW    QBRAN,EXE1
        DW    EXECU            ;execute if non-zero
EXE1:        DW    EXIT            ;do nothing if zero

;=:   CMOVE    ( b1 b2 u -- )
;        Copy u bytes from b1 to b2.

        $COLON    5,CMOVE,CMOVE
        DW    TOR
        DW    BRAN,CMOV2
CMOV1:        DW    TOR,DUPP,CAT
        DW    RAT,CSTOR
        DW    DOLIT,1,PLUS
        DW    RFROM,DOLIT,1,PLUS
CMOV2:        DW    DONXT,CMOV1
        DW    DDROP,EXIT

;=:   FILL    ( b u c -- )
;        Fill u bytes of character c to area beginning at b.

        $COLON    4,FILL,FILL
        DW    SWAP,TOR,SWAP
        DW    BRAN,FILL2
FILL1:        DW    DDUP,CSTOR,DOLIT,1,PLUS
FILL2:        DW    DONXT,FILL1
        DW    DDROP,EXIT

;=:   -TRAILING    ( b u -- b u )
;        Adjust the count to eliminate trailing white space.

        $COLON    9,-TRAILING,DTRAI
        DW    TOR
        DW    BRAN,DTRA2
DTRA1:        DW    BLANK,OVER,RAT,PLUS,CAT,LESS
        DW    QBRAN,DTRA2
        DW    RFROM,DOLIT,1,PLUS,EXIT
DTRA2:        DW    DONXT,DTRA1
        DW    DOLIT,0,EXIT

;=:   ALIGNED    ( b -- a )
;        Align address to the cell boundary.

        $COLON    7,ALIGNED,ALGND
        DW    DUPP,DOLIT,0,DOLIT,CELLL
        DW    UMMOD,DROP,DUPP
        DW    QBRAN,ALGN1
        DW    DOLIT,CELLL,SWAP,SUBB
ALGN1:        DW    PLUS,EXIT

;=:   PACK$    ( b u a -- a )
;        Build a counted string with u characters from b. Null fill.

        $COLON    5,PACK$,PACKS
        DW    ALGND,DUPP,TOR        ;strings only on cell boundary
        DW    OVER,DUPP,DOLIT,CELLL,MODD
        DW    SUBB,OVER,PLUS
        DW    DOLIT,0,SWAP,STORE    ;null fill cell
        DW    DDUP,CSTOR,DOLIT,1,PLUS    ;save count
        DW    SWAP,CMOVE,RFROM,EXIT    ;move string

;; Numeric output, single precision

;=:   DIGIT    ( u -- c )
;        Convert digit u to a character.

        $COLON    5,DIGIT,DIGIT
        DW    DOLIT,9,OVER,LESS
        DW    DOLIT,7,ANDD,PLUS
        DW    DOLIT,48,PLUS,EXIT

;=:   EXTRACT    ( n base -- n c )
;        Extract the least significant digit from n.

        $COLON    7,EXTRACT,EXTRC
        DW    DOLIT,0,SWAP,UMMOD
        DW    SWAP,DIGIT,EXIT

;=:   <#    ( -- )
;        Initiate the numeric output process.

        $COLON    2,!!!<#,BDIGS
        DW    PAD,HLD,STORE,EXIT

;=:   HOLD    ( c -- )
;        Insert a character into the numeric output string.

        $COLON    4,HOLD,HOLD
        DW    HLD,AT,DOLIT,1,SUBB
        DW    DUPP,HLD,STORE,CSTOR,EXIT

;=:   #        ( u -- u )
;        Extract one digit from u and append the digit to output string.

        $COLON    1,#,DIG
        DW    BASE,AT,EXTRC,HOLD,EXIT

;=:   #S    ( u -- 0 )
;        Convert u until all digits are added to the output string.

        $COLON    2,#S,DIGS
DIGS1:        DW    DIG,DUPP
        DW    QBRAN,DIGS2
        DW    BRAN,DIGS1
DIGS2:        DW    EXIT

;=:   SIGN    ( n -- )
;        Add a minus sign to the numeric output string.

        $COLON    4,SIGN,SIGN
        DW    ZLESS
        DW    QBRAN,SIGN1
        DW    DOLIT,45,HOLD
SIGN1:        DW    EXIT

;=:   #>    ( w -- b u )
;        Prepare the output string to be TYPE'd.

        $COLON    2,#!!!>,EDIGS
        DW    DROP,HLD,AT
        DW    PAD,OVER,SUBB,EXIT

;=:   str    ( w -- b u )
;        Convert a signed integer to a numeric string.

        $COLON    3,str,STR
        DW    DUPP,TOR,ABSS
        DW    BDIGS,DIGS,RFROM
        DW    SIGN,EDIGS,EXIT

;=:   HEX    ( -- )
;        Use radix 16 as base for numeric conversions.

        $COLON    3,HEX,HEX
        DW    DOLIT,16,BASE,STORE,EXIT

;=:   DECIMAL    ( -- )
;        Use radix 10 as base for numeric conversions.

        $COLON    7,DECIMAL,DECIM
        DW    DOLIT,10,BASE,STORE,EXIT

;; Numeric input, single precision

;=:   DIGIT?    ( c base -- u t )
;        Convert a character to its numeric value. A flag indicates success.

        $COLON    6,DIGIT?,DIGTQ
        DW    TOR,DOLIT,48,SUBB
        DW    DOLIT,9,OVER,LESS
        DW    QBRAN,DGTQ1
        DW    DOLIT,7,SUBB
        DW    DUPP,DOLIT,10,LESS,ORR
DGTQ1:        DW    DUPP,RFROM
        DW    ULESS,EXIT

;=:   NUMBER?    ( a -- n T | a F )
;        Convert a number string to integer. Push a flag on tos.

        $COLON    7,NUMBER?,NUMBQ
        DW    BASE,AT,TOR,DOLIT,0,OVER,COUNT
        DW    OVER,CAT,DOLIT,36,EQUAL
        DW    QBRAN,NUMQ1
        DW    HEX,SWAP,DOLIT,1,PLUS
        DW    SWAP,DOLIT,1,SUBB
NUMQ1:        DW    OVER,CAT,DOLIT,45,EQUAL,TOR
        DW    SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP
        DW    QBRAN,NUMQ6
        DW    DOLIT,1,SUBB,TOR
NUMQ2:        DW    DUPP,TOR,CAT,BASE,AT,DIGTQ
        DW    QBRAN,NUMQ4
        DW    SWAP,BASE,AT,STAR,PLUS,RFROM
        DW    DOLIT,1,PLUS
        DW    DONXT,NUMQ2
        DW    RAT,SWAP,DROP
        DW    QBRAN,NUMQ3
        DW    NEGAT
NUMQ3:        DW    SWAP
        DW    BRAN,NUMQ5
NUMQ4:        DW    RFROM,RFROM,DDROP,DDROP,DOLIT,FALSS
NUMQ5:        DW    DUPP
NUMQ6:        DW    RFROM,DDROP
        DW    RFROM,BASE,STORE,EXIT

;; Basic I/O

;=:   ?KEY    ( -- c T | F )
;        Return input character and true, or a false if no input.

        $COLON    4,?KEY,QKEY
        DW    TQKEY,ATEXE,EXIT

;=:   KEY    ( -- c )
;        Wait for and return an input character.

        $COLON    3,KEY,KEY
KEY1:        DW    QKEY
        DW    QBRAN,KEY1
        DW    EXIT

;=:   EMIT    ( c -- )
;        Send a character to the output device.

        $COLON    4,EMIT,EMIT
        DW    TEMIT,ATEXE,EXIT

;=:   NUF?    ( -- t )
;        Return false if no input, else pause and if CR return true.

        $COLON    4,NUF?,NUFQ
        DW    QKEY,DUPP
        DW    QBRAN,NUFQ1
        DW    DDROP,KEY,DOLIT,CRR,EQUAL
NUFQ1:        DW    EXIT

;=:   PACE    ( -- )
;        Send a pace character for the file downloading process.

        $COLON    4,PACE,PACE
        DW    DOLIT,11,EMIT,EXIT

;=:   SPACE    ( -- )
;        Send the blank character to the output device.

        $COLON    5,SPACE,SPACE
        DW    BLANK,EMIT,EXIT

;=:   SPACES    ( +n -- )
;        Send n spaces to the output device.

        $COLON    6,SPACES,SPACS
        DW    DOLIT,0,MAX,TOR
        DW    BRAN,CHAR2
CHAR1:        DW    SPACE
CHAR2:        DW    DONXT,CHAR1
        DW    EXIT

;=:   TYPE    ( b u -- )
;        Output u characters from b.

        $COLON    4,TYPE,TYPES
        DW    TOR
        DW    BRAN,TYPE2
TYPE1:        DW    DUPP,CAT,EMIT
        DW    DOLIT,1,PLUS
TYPE2:        DW    DONXT,TYPE1
        DW    DROP,EXIT

;=:   CR    ( -- )
;        Output a carriage return and a line feed.

        $COLON    2,CR,CR
        DW    DOLIT,CRR,EMIT
        DW    DOLIT,LF,EMIT,EXIT

;=:   do$    ( -- a )
;        Return the address of a compiled string.

        $COLON    COMPO+3,do$,DOSTR
        DW    RFROM,RAT,RFROM,COUNT,PLUS
        DW    ALGND,TOR,SWAP,TOR,EXIT

;=:   $"|    ( -- a )
;        Run time routine compiled by $". Return address of a compiled string.

        $COLON    COMPO+3,$!!!"|,STRQB
        DW    DOSTR,EXIT        ;force a call to do$

;=:   ."|    ( -- )
;        Run time routine of ." . Output a compiled string.

        $COLON    COMPO+3,.!!!"|,DOTQB
        DW    DOSTR,COUNT,TYPES,EXIT

;=:   .R    ( n +n -- )
;        Display an integer in a field of n columns, right justified.

        $COLON    2,.R,DOTR
        DW    TOR,STR,RFROM,OVER,SUBB
        DW    SPACS,TYPES,EXIT

;=:   U.R    ( u +n -- )
;        Display an unsigned integer in n column, right justified.

        $COLON    3,U.R,UDOTR
        DW    TOR,BDIGS,DIGS,EDIGS
        DW    RFROM,OVER,SUBB
        DW    SPACS,TYPES,EXIT

;=:   U.    ( u -- )
;        Display an unsigned integer in free format.

        $COLON    2,U.,UDOT
        DW    BDIGS,DIGS,EDIGS
        DW    SPACE,TYPES,EXIT

;=:   .        ( w -- )
;        Display an integer in free format, preceeded by a space.

        $COLON    1,.,DOT
        DW    BASE,AT,DOLIT,10,XORR    ;?decimal
        DW    QBRAN,DOT1
        DW    UDOT,EXIT        ;no, display unsigned
DOT1:        DW    STR,SPACE,TYPES,EXIT    ;yes, display signed

;=:   ?        ( a -- )
;        Display the contents in a memory cell.

        $COLON    1,?,QUEST
        DW    AT,DOT,EXIT

;; Parsing

;=:   parse    ( b u c -- b u delta ; <string> )
;        Scan string delimited by c. Return found string and its offset.

        $COLON    5,parse,PARS
        DW    TEMP,STORE,OVER,TOR,DUPP
        DW    QBRAN,PARS8
        DW    DOLIT,1,SUBB,TEMP,AT,BLANK,EQUAL
        DW    QBRAN,PARS3
        DW    TOR
PARS1:        DW    BLANK,OVER,CAT        ;skip leading blanks ONLY
        DW    SUBB,ZLESS,INVER
        DW    QBRAN,PARS2
        DW    DOLIT,1,PLUS
        DW    DONXT,PARS1
        DW    RFROM,DROP,DOLIT,0,DUPP,EXIT
PARS2:        DW    RFROM
PARS3:        DW    OVER,SWAP
        DW    TOR
PARS4:        DW    TEMP,AT,OVER,CAT,SUBB    ;scan for delimiter
        DW    TEMP,AT,BLANK,EQUAL
        DW    QBRAN,PARS5
        DW    ZLESS
PARS5:        DW    QBRAN,PARS6
        DW    DOLIT,1,PLUS
        DW    DONXT,PARS4
        DW    DUPP,TOR
        DW    BRAN,PARS7
PARS6:        DW    RFROM,DROP,DUPP
        DW    DOLIT,1,PLUS,TOR
PARS7:        DW    OVER,SUBB
        DW    RFROM,RFROM,SUBB,EXIT
PARS8:        DW    OVER,RFROM,SUBB,EXIT

;=:   PARSE    ( c -- b u ; <string> )
;        Scan input stream and return counted string delimited by c.

        $COLON    5,PARSE,PARSE
        DW    TOR,TIB,INN,AT,PLUS    ;current input buffer pointer
        DW    NTIB,AT,INN,AT,SUBB    ;remaining count
        DW    RFROM,PARS,INN,PSTOR,EXIT

;=:   .(    ( -- )
;        Output following string up to next ) .

        $COLON    IMEDD+2,.(,DOTPR
        DW    DOLIT,41,PARSE,TYPES,EXIT

;=:   (        ( -- )
;        Ignore following string up to next ) . A comment.

        $COLON    IMEDD+1,(,PAREN
        DW    DOLIT,41,PARSE,DDROP,EXIT

;=:   \        ( -- )
;        Ignore following text till the end of line.

        $COLON    IMEDD+1,\,BKSLA
        DW    NTIB,AT,INN,STORE,EXIT

;=:   CHAR    ( -- c )
;        Parse next word and return its first character.

        $COLON    4,CHAR,CHAR
        DW    BLANK,PARSE,DROP,CAT,EXIT

;=:   TOKEN    ( -- a ; <string> )
;        Parse a word from input stream and copy it to name dictionary.

        $COLON    5,TOKEN,TOKEN
        DW    BLANK,PARSE,DOLIT,31,MIN
        DW    NP,AT,OVER,SUBB,CELLM
        DW    PACKS,EXIT

;=:   WORD    ( c -- a ; <string> )
;        Parse a word from input stream and copy it to code dictionary.

        $COLON    4,WORD,WORDD
        DW    PARSE,HERE,PACKS,EXIT

;; Dictionary Search

;=:   NAME>    ( na -- ca )
;        Return code field address of a word from its name field address.

        $COLON    5,NAME!!!>,NAMET
        DW    CELLM,CELLM,AT,EXIT

;=:   SAME?    ( a a u -- a a f \ -0+ )
;        Compare u cells in two strings. Return 0 if identical.

        $COLON    5,SAME?,SAMEQ
        DW    TOR
        DW    BRAN,SAME2
SAME1:        DW    OVER,RAT,CELLS,PLUS,AT
        DW    OVER,RAT,CELLS,PLUS,AT
        DW    SUBB,QDUP
        DW    QBRAN,SAME2
        DW    RFROM,DROP,EXIT
SAME2:        DW    DONXT,SAME1
        DW    DOLIT,FALSS,EXIT

;=:   find    ( a va -- ca na | a F )
;        Search a vocabulary for a string. Return ca and na if succeeded.

        $COLON    4,find,FIND
        DW    SWAP,DUPP,CAT,DOLIT
        DW    CELLL,SLASH,TEMP,STORE
        DW    DUPP,AT,TOR,CELLP,SWAP
FIND1:        DW    AT,DUPP
        DW    QBRAN,FIND6
        DW    DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR
        DW    QBRAN,FIND2
        DW    CELLP,DOLIT,-1
        DW    BRAN,FIND3
FIND2:        DW    CELLP,TEMP,AT,SAMEQ
FIND3:        DW    BRAN,FIND4
FIND6:        DW    RFROM,DROP
        DW    SWAP,CELLM,SWAP,EXIT
FIND4:        DW    QBRAN,FIND5
        DW    CELLM,CELLM
        DW    BRAN,FIND1
FIND5:        DW    RFROM,DROP,SWAP,DROP
        DW    CELLM
        DW    DUPP,NAMET,SWAP,EXIT

;=:   NAME?    ( a -- ca na | a F )
;        Search all context vocabularies for a string.

        $COLON    5,NAME?,NAMEQ
        DW    CNTXT,DUPP,DAT,XORR
        DW    QBRAN,NAMQ1
        DW    CELLM
NAMQ1:        DW    TOR
NAMQ2:        DW    RFROM,CELLP,DUPP,TOR
        DW    AT,QDUP
        DW    QBRAN,NAMQ3
        DW    FIND,QDUP
        DW    QBRAN,NAMQ2
        DW    RFROM,DROP,EXIT
NAMQ3:        DW    RFROM,DROP
        DW    DOLIT,FALSS,EXIT

;; Terminal response

;=:   ^H    ( bot eot cur -- bot eot cur )
;        Backup the cursor by one character.

        $COLON    2,!!!^H,BKSP
        DW    TOR,OVER,RFROM,SWAP,OVER,XORR
        DW    QBRAN,BACK1
        DW    DOLIT,BKSPP,TECHO,ATEXE,DOLIT,1,SUBB
        DW    BLANK,TECHO,ATEXE
        DW    DOLIT,BKSPP,TECHO,ATEXE
BACK1:        DW    EXIT

;=:   TAP    ( bot eot cur c -- bot eot cur )
;        Accept and echo the key stroke and bump the cursor.

        $COLON    3,TAP,TAP
        DW    DUPP,TECHO,ATEXE
        DW    OVER,CSTOR,DOLIT,1,PLUS,EXIT

;=:   kTAP    ( bot eot cur c -- bot eot cur )
;        Process a key stroke, CR or backspace.

        $COLON    4,kTAP,KTAP
        DW    DUPP,DOLIT,CRR,XORR
        DW    QBRAN,KTAP3
        DW    DOLIT,BKSPP,XORR
        DW    QBRAN,KTAP1
        DW    BLANK,TAP
        DW    BRAN,KTAP2
KTAP1:        DW    BKSP
KTAP2:        DW    EXIT
KTAP3:        DW    DROP
        DW    SWAP,DROP,DUPP,EXIT

;=:   accept    ( b u -- b u )
;        Accept characters to input buffer. Return with actual count.

        $COLON    6,accept,ACCEP
        DW    OVER,PLUS,OVER
ACCP1:        DW    DDUP,XORR
        DW    QBRAN,ACCP4
        DW    KEY,DUPP,BLANK,SUBB
        DW    DOLIT,95,ULESS
        DW    QBRAN,ACCP2
        DW    TAP
        DW    BRAN,ACCP3
ACCP2:        DW    TTAP,ATEXE
ACCP3:        DW    BRAN,ACCP1
ACCP4:        DW    DROP,OVER,SUBB,EXIT

;=:   EXPECT    ( b u -- )
;        Accept input stream and store count in SPAN.

        $COLON    6,EXPECT,EXPEC
        DW    TEXPE,ATEXE,SPAN,STORE,DROP,EXIT

;=:   QUERY    ( -- )
;        Accept input stream to terminal input buffer.

        $COLON    5,QUERY,QUERY
        DW    TIB,DOLIT,80,TEXPE,ATEXE,NTIB,STORE
        DW    DROP,DOLIT,0,INN,STORE,EXIT

;; Error handling

;=:   CATCH    ( ca -- 0 | err# )
;        Execute word at ca and set up an error frame for it.

        $COLON    5,CATCH,CATCH
        DW    SPAT,TOR,HANDL,AT,TOR    ;save error frame
        DW    RPAT,HANDL,STORE,EXECU    ;execute
        DW    RFROM,HANDL,STORE    ;restore error frame
        DW    RFROM,DROP,DOLIT,0,EXIT    ;no error

;=:   THROW    ( err# -- err# )
;        Reset system to current local error frame an update error flag.

        $COLON    5,THROW,THROW
        DW    HANDL,AT,RPSTO        ;restore return stack
        DW    RFROM,HANDL,STORE    ;restore handler frame
        DW    RFROM,SWAP,TOR,SPSTO    ;restore data stack
        DW    DROP,RFROM,EXIT

;=:   NULL$    ( -- a )
;        Return address of a null string with zero count.

        $COLON    5,NULL$,NULLS
        DW    DOVAR            ;emulate CREATE
        DW    0

;=:   ABORT    ( -- )
;        Reset data stack and jump to QUIT.

        $COLON    5,ABORT,ABORT
        DW    NULLS,THROW

;=:   abort"    ( f -- )
;        Run time routine of ABORT" . Abort with a message.

        $COLON    COMPO+6,abort!!!",ABORQ
        DW    QBRAN,ABOR1        ;text flag
        DW    DOSTR,THROW        ;pass error string
ABOR1:        DW    DOSTR,DROP,EXIT        ;drop error

;; Interpret

;=:   $INTERPRET    ( a -- )
;        Interpret a word. If failed, convert it to an integer.

        $COLON    10,$INTERPRET,INTER
        DW    NAMEQ,QDUP        ;?defined
        DW    QBRAN,INTE1
        DW    AT,DOLIT,COMPO,ANDD    ;?compile only lexicon bits
        DW    ABORQ
        DB    13,' compile only'
        DW    EXECU,EXIT        ;execute defined word
INTE1:        DW    TNUMB,ATEXE        ;convert a number
        DW    QBRAN,INTE2
        DW    EXIT
INTE2:        DW    THROW            ;error

;=:   [        ( -- )
;        Start the text interpreter.

        $COLON    IMEDD+1,[,LBRAC
        DW    DOLIT,INTER,TEVAL,STORE,EXIT

;=:   .OK    ( -- )
;        Display 'ok' only while interpreting.

        $COLON    3,.OK,DOTOK
        DW    DOLIT,INTER,TEVAL,AT,EQUAL
        DW    QBRAN,DOTO1
        DW    DOTQB
        DB    3,' ok'
DOTO1:        DW    CR,EXIT

;=:   ?STACK    ( -- )
;        Abort if the data stack underflows.

        $COLON    6,?STACK,QSTAC
        DW    DEPTH,ZLESS        ;check only for underflow
        DW    ABORQ
        DB    11,' underflow '
        DW    EXIT

;=:   EVAL    ( -- )
;        Interpret the input stream.

        $COLON    4,EVAL,EVAL
EVAL1:        DW    TOKEN,DUPP,CAT        ;?input stream empty
        DW    QBRAN,EVAL2
        DW    TEVAL,ATEXE,QSTAC    ;evaluate input, check stack
        DW    BRAN,EVAL1
EVAL2:        DW    DROP,TPROM,ATEXE,EXIT    ;prompt

;; Shell

;=:   PRESET    ( -- )
;        Reset data stack pointer and the terminal input buffer.

        $COLON    6,PRESET,PRESE
        DW    SZERO,AT,SPSTO
        DW    DOLIT,TIBB,NTIB,CELLP,STORE,EXIT

;=:   XIO    ( a a a -- )
;        Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT.

        $COLON    3,XIO,XIO
        DW    DOLIT,ACCEP,TEXPE,STORE,TTAP,STORE
        DW    TECHO,STORE,TPROM,STORE,EXIT

;=:   FILE    ( -- )
;        Select I/O vectors for file download.

        $COLON    4,FILE,FILE
        DW    DOLIT,PACE,DOLIT,DROP
        DW    DOLIT,KTAP,XIO,EXIT

;=:   HAND    ( -- )
;        Select I/O vectors for terminal interface.

        $COLON    4,HAND,HAND
        DW    DOLIT,DOTOK,TEMIT,AT
        DW    DOLIT,KTAP,XIO,EXIT

;=:   I/O    ( -- a )
;        Array to store default I/O vectors.

        $COLON    3,I/O,ISLO
        DW    DOVAR            ;emulate CREATE
        DW    QRX,STOTX        ;default I/O vectors

;=:   CONSOLE    ( -- )
;        Initiate terminal interface.

        $COLON    7,CONSOLE,CONSO
        DW    ISLO,DAT,TQKEY,DSTOR    ;restore default I/O device
        DW    HAND,EXIT        ;keyboard input

;=:   QUIT    ( -- )
;        Reset return stack pointer and start text interpreter.

        $COLON    4,QUIT,QUIT
        DW    RZERO,AT,RPSTO        ;reset return stack pointer
QUIT1:        DW    LBRAC            ;start interpretation
QUIT2:        DW    QUERY            ;get input
        DW    DOLIT,EVAL,CATCH,QDUP    ;evaluate input
        DW    QBRAN,QUIT2        ;continue till error
        DW    TPROM,AT,TOR        ;save input device
        DW    CONSO,NULLS,OVER,XORR    ;?display error message
        DW    QBRAN,QUIT3
        DW    SPACE,COUNT,TYPES    ;error message
        DW    DOTQB
        DB    3,' ? '            ;error prompt
QUIT3:        DW    RFROM,DOLIT,DOTOK,XORR    ;?file input
        DW    QBRAN,QUIT4
        DW    DOLIT,ERR,EMIT        ;file error, tell host
QUIT4:        DW    PRESE            ;some cleanup
        DW    BRAN,QUIT1

;=:   '        ( -- ca )
;        Search context vocabularies for the next word in input stream.

        $COLON    1,!!!',TICK,TICKY
        DW    TOKEN,NAMEQ        ;?defined
        DW    QBRAN,TICK1
        DW    EXIT            ;yes, return code address
TICK1:        DW    THROW            ;no, error

;; The compiler

;=:   ALLOT    ( n -- )
;        Allocate n bytes to the code dictionary.

        $COLON    5,ALLOT,ALLOT
        DW    CP,PSTOR,EXIT        ;adjust code pointer

;=:   ,        ( w -- )
;        Compile an integer into the code dictionary.

        $COLON    1,!!!,,COMMA
        DW    HERE,DUPP,CELLP        ;cell boundary
        DW    CP,STORE,STORE,EXIT    ;adjust code pointer and compile

;=:   [COMPILE]    ( -- ; <string> )
;        Compile the next immediate word into code dictionary.

        $COLON    IMEDD+9,[COMPILE],BCOMP
        DW    TICK,COMMA,EXIT

;=:   COMPILE    ( -- )
;        Compile the next address in colon list to code dictionary.

        $COLON    COMPO+7,COMPILE,COMPI
        DW    RFROM,DUPP,AT,COMMA    ;compile address
        DW    CELLP,TOR,EXIT        ;adjust return address

;=:   LITERAL    ( w -- )
;        Compile tos to code dictionary as an integer literal.

        $COLON    IMEDD+7,LITERAL,LITER
        DW    COMPI,DOLIT,COMMA,EXIT

;=:   $,"    ( -- )
;        Compile a literal string up to next " .

        $COLON    3,$!!!,!!!",STRNG
        DW    DOLIT,34,WORDD,CAT    ;move string to code dictionary
        DW    DOLIT,1,PLUS,ALLOT,EXIT    ;adjust the code pointer

;=:   RECURSE    ( -- )
;        Make the current word available for compilation.

        $COLON    IMEDD+7,RECURSE,RECUR
        DW    LAST,AT,NAMET,COMMA,EXIT

;; Structures

;=:   FOR    ( -- a )
;        Start a FOR-NEXT loop structure in a colon definition.

        $COLON    IMEDD+3,FOR,FOR
        DW    COMPI,TOR,HERE,EXIT

;=:   BEGIN    ( -- a )
;        Start an infinite or indefinite loop structure.

        $COLON    IMEDD+5,BEGIN,BEGIN
        DW    HERE,EXIT

;=:   NEXT    ( a -- )
;        Terminate a FOR-NEXT loop structure.

        $COLON    IMEDD+4,NEXT,NEXT
        DW    COMPI,DONXT,COMMA,EXIT

;=:   UNTIL    ( a -- )
;        Terminate a BEGIN-UNTIL indefinite loop structure.

        $COLON    IMEDD+5,UNTIL,UNTIL
        DW    COMPI,QBRAN,COMMA,EXIT

;=:   AGAIN    ( a -- )
;        Terminate a BEGIN-AGAIN infinite loop structure.

        $COLON    IMEDD+5,AGAIN,AGAIN
        DW    COMPI,BRAN,COMMA,EXIT

;=:   IF    ( -- A )
;        Begin a conditional branch structure.

        $COLON    IMEDD+2,IF,IFF
        DW    COMPI,QBRAN,HERE
        DW    DOLIT,0,COMMA,EXIT

;=:   AHEAD    ( -- A )
;        Compile a forward branch instruction.

        $COLON    IMEDD+5,AHEAD,AHEAD
        DW    COMPI,BRAN,HERE,DOLIT,0,COMMA,EXIT

;=:   REPEAT    ( A a -- )
;        Terminate a BEGIN-WHILE-REPEAT indefinite loop.

        $COLON    IMEDD+6,REPEAT,REPEA
        DW    AGAIN,HERE,SWAP,STORE,EXIT

;=:   THEN    ( A -- )
;        Terminate a conditional branch structure.

        $COLON    IMEDD+4,THEN,THENN
        DW    HERE,SWAP,STORE,EXIT

;=:   AFT    ( a -- a A )
;        Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through.

        $COLON    IMEDD+3,AFT,AFT
        DW    DROP,AHEAD,BEGIN,SWAP,EXIT

;=:   ELSE    ( A -- A )
;        Start the false clause in an IF-ELSE-THEN structure.

        $COLON    IMEDD+4,ELSE,ELSEE
        DW    AHEAD,SWAP,THENN,EXIT

;=:   WHILE    ( a -- A a )
;        Conditional branch out of a BEGIN-WHILE-REPEAT loop.

        $COLON    IMEDD+5,WHILE,WHILE
        DW    IFF,SWAP,EXIT

;=:   ABORT"    ( -- ; <string> )
;        Conditional abort with an error message.

        $COLON    IMEDD+6,ABORT!!!",ABRTQ
        DW    COMPI,ABORQ,STRNG,EXIT

;=:   $"    ( -- ; <string> )
;        Compile an inline string literal.

        $COLON    IMEDD+2,$!!!",SQUOT
        DW    COMPI,STRQB,STRNG,EXIT

;=:   ."    ( -- ; <string> )
;        Compile an inline string literal to be typed out at run time.

        $COLON    IMEDD+2,.!!!",DOTQ
        DW    COMPI,DOTQB,STRNG,EXIT

;; Name Compiler

;=:   ?UNIQUE    ( a -- a )
;        Display a warning message if word at a exists in dictionary.

        $COLON    7,?UNIQUE,UNIQU
        DW    DUPP,NAMEQ        ;?name exists
        DW    QBRAN,UNIQ1
        DW    DOTQB            ;its OK to redefine a word
        DB    7,' reDef '        ;but the user should be warned
        DW    OVER,COUNT,TYPES    ;just in case its not planned
UNIQ1:        DW    DROP,EXIT

;=:   $,n    ( na -- )
;        Build a new dictionary name using the string at na.

        $COLON    3,$!!!,n,SNAME
        DW    DUPP,CAT        ;?null input
        DW    QBRAN,PNAM1
        DW    UNIQU            ;?redefinition
        DW    DUPP,LAST,STORE        ;save na for vocabulary link
        DW    HERE,ALGND,SWAP        ;align code address
        DW    CELLM            ;link address
        DW    CRRNT,AT,AT,OVER,STORE
        DW    CELLM,DUPP,NP,STORE    ;adjust name pointer
        DW    STORE,EXIT        ;save code pointer
PNAM1:        DW    STRQB
        DB    5,' name'        ;null input
        DW    THROW

;; FORTH Compiler

;=:   $COMPILE    ( a -- )
;        Compile next word to code dictionary as a token or literal.

        $COLON    8,$COMPILE,SCOMP
        DW    NAMEQ,QDUP        ;?defined
        DW    QBRAN,SCOM3
        DW    AT,DOLIT,IMEDD,ANDD    ;?immediate
        DW    QBRAN,SCOM1
        DW    EXECU            ;its immediate, execute
        DW    BRAN,SCOM2
SCOM1:        DW    COMMA            ;its not immediate, compile
SCOM2:        DW    EXIT
SCOM3:        DW    TNUMB,ATEXE        ;try to convert to number
        DW    QBRAN,SCOM4
        DW    LITER,EXIT        ;compile number as integer
SCOM4:        DW    THROW            ;error

;=:   OVERT    ( -- )
;        Link a new word into the current vocabulary.

        $COLON    5,OVERT,OVERT
        DW    LAST,AT,CRRNT,AT,STORE,EXIT

;=:   ;        ( -- )
;        Terminate a colon definition.

        $COLON    IMEDD+COMPO+1,!!!;,SEMIS
        DW    COMPI,EXIT,LBRAC,OVERT,EXIT

;=:   ]        ( -- )
;        Start compiling the words in the input stream.

        $COLON    1,],RBRAC
        DW    DOLIT,SCOMP,TEVAL,STORE,EXIT

;=:   call,    ( ca -- )
;        Assemble a call instruction to ca.

        $COLON    5,call!!!,,CALLC
        DW    DOLIT,CALLL,COMMA,HERE    ;Direct Threaded Code
        DW    CELLP,SUBB,COMMA,EXIT    ;DTC 8086 relative call

;=:   :        ( -- ; <string> )
;        Start a new colon definition using next word as its name.

        $COLON    1,!!!:,COLON
        DW    TOKEN,SNAME,DOLIT,DOLST
        DW    CALLC,RBRAC,EXIT

;=:   IMMEDIATE    ( -- )
;        Make the last compiled word an immediate word.

        $COLON    9,IMMEDIATE,IMMED
        DW    DOLIT,IMEDD,LAST,AT,AT,ORR
        DW    LAST,AT,STORE,EXIT

;; Defining Words

;=:   USER    ( u -- ; <string> )
;        Compile a new user variable.

        $COLON    4,USER,USER
        DW    TOKEN,SNAME,OVERT
        DW    DOLIT,DOLST,CALLC
        DW    DOLIT,DOUSE,COMMA
        DW    COMMA,EXIT

;=:   CREATE    ( -- ; <string> )
;        Compile a new array entry without allocating code space.

        $COLON    6,CREATE,CREAT
        DW    TOKEN,SNAME,OVERT
        DW    DOLIT,DOLST,CALLC
        DW    DOLIT,DOVAR,COMMA,EXIT

;=:   VARIABLE    ( -- ; <string> )
;        Compile a new variable initialized to 0.

        $COLON    8,VARIABLE,VARIA
        DW    CREAT,DOLIT,0,COMMA,EXIT

;=:   FORTH    ( -- )???
;        Make FORTH vocabulary the context vocabulary.

        $COLON    5,FORTH,FORTH
        DW    VOCAB,CNTXT,STORE,EXIT

;; Tools

;=:   _TYPE    ( b u -- )
;        Display a string. Non-printing characters are replaced by periods.

        $COLON    5,_TYPE,UTYPE
        DW    TOR            ;start count down loop
        DW    BRAN,UTYP2        ;skip first pass
UTYP1:        DW    DUPP,CAT,TCHAR,EMIT    ;display only printable
        DW    DOLIT,1,PLUS        ;increment address
UTYP2:        DW    DONXT,UTYP1        ;loop till done
        DW    DROP,EXIT

;=:   dm+    ( a u -- a )
;        Dump u bytes from a, leaving a+u on the stack.

        $COLON    3,dm+,DUMPP
        DW    OVER,DOLIT,4,UDOTR    ;display address
        DW    SPACE,TOR        ;start count down loop
        DW    BRAN,PDUM2        ;skip first pass
PDUM1:        DW    DUPP,CAT,DOLIT,3,UDOTR    ;display numeric data
        DW    DOLIT,1,PLUS        ;increment address
PDUM2:        DW    DONXT,PDUM1        ;loop till done
        DW    EXIT

;=:   DUMP    ( a u -- )
;        Dump u bytes from a, in a formatted manner.

        $COLON    4,DUMP,DUMP
        DW    BASE,AT,TOR,HEX        ;save radix, set hex
        DW    DOLIT,16,SLASH        ;change count to lines
        DW    TOR            ;start count down loop
DUMP1:        DW    CR,DOLIT,16,DDUP,DUMPP    ;display numeric
        DW    ROT,ROT
        DW    DOLIT,2,SPACS,UTYPE    ;display printable characters
        DW    NUFQ,INVER        ;user control
        DW    QBRAN,DUMP2
        DW    DONXT,DUMP1        ;loop till done
        DW    BRAN,DUMP3
DUMP2:        DW    RFROM,DROP        ;cleanup loop stack, early exit
DUMP3:        DW    DROP,RFROM,BASE,STORE    ;restore radix
        DW    EXIT

;=:   .S    ( ... -- ... )
;        Display the contents of the data stack.

        $COLON    2,.S,DOTS
        DW    CR,DEPTH        ;stack depth
        DW    TOR            ;start count down loop
        DW    BRAN,DOTS2        ;skip first pass
DOTS1:        DW    RAT,PICK,DOT        ;index stack, display contents
DOTS2:        DW    DONXT,DOTS1        ;loop till done
        DW    DOTQB
        DB    5,' <sp '        ;user friendly
        DW    EXIT

;=:   !CSP    ( -- )
;        Save stack pointer in CSP for error checking.

        $COLON    4,!!!!CSP,STCSP
        DW    SPAT,CSP,STORE,EXIT    ;save pointer

;=:   ?CSP    ( -- )
;        Abort if stack pointer differs from that saved in CSP.

        $COLON    4,?CSP,QCSP
        DW    SPAT,CSP,AT,XORR    ;compare pointers
        DW    ABORQ            ;abort if different
        DB    11,'stack depth'
        DW    EXIT

;=:   >NAME    ( ca -- na | F )
;        Convert code address to a name address.

        $COLON    5,!!!>NAME,TNAME
        DW    CRRNT            ;vocabulary link
TNAM1:        DW    CELLP,AT,QDUP        ;check all vocabularies
        DW    QBRAN,TNAM4
        DW    DDUP
TNAM2:        DW    AT,DUPP            ;?last word in a vocabulary
        DW    QBRAN,TNAM3
        DW    DDUP,NAMET,XORR        ;compare
        DW    QBRAN,TNAM3
        DW    CELLM            ;continue with next word
        DW    BRAN,TNAM2
TNAM3:        DW    SWAP,DROP,QDUP
        DW    QBRAN,TNAM1
        DW    SWAP,DROP,SWAP,DROP,EXIT
TNAM4:        DW    DROP,DOLIT,FALSS,EXIT

;=:   .ID    ( na -- )
;        Display the name at address.

        $COLON    3,.ID,DOTID
        DW    QDUP            ;if zero no name
        DW    QBRAN,DOTI1
        DW    COUNT,DOLIT,1FH,ANDD    ;mask lexicon bits
        DW    UTYPE,EXIT        ;display name string
DOTI1:        DW    DOTQB
        DB    9,' {noName}'
        DW    EXIT

;=:   SEE    ( -- ; <string> )
;        A simple definition decompiler.

        $COLON    3,SEE,SEE
        DW    CR,TICK,CELLP        ;starting address
SEE1:        DW    CELLP,DUPP,AT,DUPP    ;?does it contain a zero
        DW    QBRAN,SEE2
        DW    TNAME            ;?is it a name
SEE2:        DW    QDUP            ;name address or zero
        DW    QBRAN,SEE3
        DW    SPACE,DOTID        ;display name
        DW    BRAN,SEE4
SEE3:        DW    DUPP,AT,UDOT        ;display number
SEE4:        DW    NUFQ            ;user control
        DW    QBRAN,SEE1
        DW    DROP,EXIT

;=:   WORDS    ( -- )
;        Display the word names in the context vocabulary.

        $COLON    5,WORDS,WORDS
        DW    CR,CNTXT,AT        ;only words in context
WORS1:        DW    AT,QDUP            ;?at end of list
        DW    QBRAN,WORS2
        DW    DUPP,SPACE,DOTID    ;display a name
        DW    CELLM,NUFQ        ;user pause or continue
        DW    QBRAN,WORS1
        DW    DROP
WORS2:        DW    EXIT

;; Hardware reset

;=:   VER    ( -- n )
;        Return the version number of this implementation.

        $COLON    3,VER,VERSN
        DW    DOLIT,VER*256+EXT,EXIT

;=:   hi    ( -- )
;        Display the sign-on message of eForth.

        $COLON    2,hi,HI
        DW    STOIO,CR,DOTQB
        DB    11,'eForth v'
        DB    VER+48,46,EXT+48    ;version
        DW    CR,EXIT

;=:   'BOOT    ( -- a )
;        The application startup vector.

        $COLON    5,!!!'BOOT,TBOOT,TICKY
        DW    DOVAR
        DW    HI            ;application to boot

;=:   COLD    ( -- )
;        The hilevel cold start sequence.

        $COLON    4,COLD,COLD
COLD1:        DW    DOLIT,UZERO,DOLIT,UPP
        DW    DOLIT,ULAST-UZERO,CMOVE    ;initialize user area
        DW    PRESE            ;initialize data stack and TIB
        DW    TBOOT,ATEXE        ;application boot
        DW    QUIT,EXIT        ;start interpretation

;====================================================================

LASTN        EQU    _NAME+4            ;last name address in name dictionary.

NTOP        EQU    _NAME-0            ;next available memory in name dictionary.
CTOP        EQU    $+0            ;next available memory in code dictionary.

MAIN        ENDS

END    ORIG

;====================================================================