include "inc/cmdsys.plh"
include "inc/args.plh"
include "inc/fileio.plh"
include "inc/conio.plh"
include "inc/longjmp.plh"
sysflags restxt1|resxtxt1    // Reserve 80 column text pages
//
// Internal variables
//
const JSR        = $20 // 6502 JSR opcode needed for VM entry
const RTS        = $60 // 6502 RTS opcode
const JMP        = $4C // 6502 JMP opcode
const SRCREFS    = 2
const INBUF_SIZE = 128
word  latest, infunc, inptr, IIP, W
word  vmvect, startheap, arg
byte  srclevel   = 0
//
// Internal buffers
//
word          strbuf, inbuf
res[t_except] exitforth
//
// Input references, pointers, and saved values
//
byte  nullstr = 0
word  keyinbuf = @nullstr // Point somewhere benign for starters (updated in keyin)
word  inbufptr = @nullstr
byte  inref[SRCREFS]
word  previnptr[SRCREFS]
//
// RSTACK
//
const RSTK_SIZE = 16
byte RSP = RSTK_SIZE
word RSTACK[RSTK_SIZE]
//
// Vocabulary hash table
//
const HASH_SIZE = 64 // Must be power of two!
const HASH_MASK = HASH_SIZE-1
word hashtbl[HASH_SIZE]
//
// State flags
//
const exit_flag     = $01
const trace_flag    = $02
const step_flag     = $04
const comp_itc_flag = $10
const comp_pbc_flag = $20
const comp_flag     = comp_itc_flag | comp_pbc_flag
//
// Mode and state
//
byte comp_mode = comp_pbc_flag
byte state     = 0
word brkentry  = 0
word brkcfa    = 0
byte brk       = 0
//
// FORTH dictionary layout
//
//  bytes   usage
//  -----   -----
// [1]      name length
// [1..255] name
// [1]      FFA (flag field address)
// [2]      LFA (link field address)
// [2]      HFA (hash field address)
// [2]      CFA (code field address)
// [2..]    PFA (param field address)
//
// Mask and flags for dictionary entries
//
const inline_flag     = $01
const inlinew_flag    = $02
const param_flag      = $04
const showcr_flag     = $08 // Help pretty print SHOW
const itc_flag        = $10
const imm_flag        = $20
const componly_flag   = $40
const interponly_flag = $80
//
// Predefine instrinsics
//
predef _swap_(a,b)#2, _ifdup_(a)#1, _over_(a,b)#3, _rot_(a,b,c)#3, _dup2_(a,b)#4
predef _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1, _wplusset_(a,b)#0
predef _ffa_(a)#1, _lfa_(a)#1, _hfa_(a)#1, _cfa_(a)#1, _pfa_(a)#1, _allot_(a)#0
predef _branch_#0, _0branch_(a)#0, _if_#0, _else_#0, _then_#0
predef _begin_#0, _again_#0, _until_#0, _while_#0, _repeat_#0
predef _case_#0, _of_#0, _endof_#0, _endcase_#0
predef _dodo_(a,b)#0, _do_#0, _doloop_#0, _doplusloop_(a)#0, _plusloop_#0, _loop_#0
predef _unloop_#0, _leave_#0, _j_#1, _defer_#0, _is_(a)#0, _noname_#0
predef _create_#0, _itcdoes_(a)#0, _does_#0, _compoff_#0, _compon_#0, _state_#1
predef _postpone_#0, _dictaddw_(a)#0, _dictaddb_(a)#0, _colon_#0, _semi_#0
predef _componly_#0, _interponly_#0, _immediate_#0, _exit_#0, _pad_#1, _trailing_(a,b)#2
predef _tors_(a)#0, _fromrs_#1, _toprs_#1, _lookup_#1, _latest_#1, _recurse_#0
predef _cmove_(a,b,c)#0, _move_(a,b,c)#0, _fill_(a,b,c)#0, _plasma_(a)#0
predef _compare_(a,b,c,d)#1, _var_(a)#0, _const_(a)#0, _lit_#1, _slit_#1, _find_(a)#2
predef _tick_#0, _forget_#0, _keypressed_#1, _key_#1, _prat_(a)#0
predef _blank_#0, _char_#0, _str_#0, _prstr_#0, _prpstr_#0
predef _prval_(a)#0, _prbyte_(a)#0, _prhex_(a)#0, _prbin_(a)#0, _prbinw_(a)#0
predef _accept_(a,b)#1, _type_(a,b)#0
predef _words_#0, _tron_#0, _troff_#0, _stepon_#0, _stepoff_#0
predef _itc_#0, _pbc_#0, _comment_#0, _src_(a)#0, _srcstr_#0, _endsrc_#0, _ifendsrc_(a)#0
predef _brk_#0, _brkon_#0, _brkoff_#0, _word_(a)#1, _count_(a)#2
predef _space_#0, _spaces_(a)#0, _see_#0, _prstack_#0, _prrstack_#0
predef _cont_#0, _restart_#0, _bye_#0, _quit_#0
predef _abort_(a)#0, _doabortstr_(a,b)#0, _abortstr_#0
predef _compword_(dentry)#0, _compliteral_(a)#0, _execword_(dentry)#0, _isnum_(a,b)#2
predef _interpret_#0
//
// Forth Vocabulary
//
// DROP
char d_drop = "DROP", inline_flag | showcr_flag; word = 0, 0, 0, $30
// DROP2
char d_drop2 = "DROP2", inlinew_flag | showcr_flag; word = @d_drop, 0, 0, $3030
// SWAP
char d_swap = "SWAP", 0; word = @d_drop2, 0, @_swap_
// DUP
char d_dup = "DUP", inline_flag; word = @d_swap, 0, 0, $34
// DUP2
char d_dup2 = "DUP2", 0; word = @d_dup, 0, @_dup2_
// ?DUP
char d_ifdup = "?DUP", 0; word = @d_dup2, 0, @_ifdup_
// OVER
char d_over = "OVER",  0; word = @d_ifdup, 0, @_over_
// ROT
char d_rot = "ROT", 0; word = @d_over, 0, @_rot_
// ADD
char d_add = "+", inline_flag; word = @d_rot, 0, 0, $82
// ONE PLUS
char d_inc = "1+", inline_flag; word = @d_add, 0, 0, $8C
// TWO PLUS
char d_inc2 = "2+", inlinew_flag; word = @d_inc, 0, 0, $8C8C
// ONE MINUS
char d_dec = "1-", inline_flag; word = @d_inc2, 0, 0, $8E
// TWO MINUS
char d_dec2 = "2-", inlinew_flag; word = @d_dec, 0, 0, $8E8E
// SUB
char d_sub = "-", inline_flag; word = @d_dec2, 0, 0, $84
// MUL
char d_mul = "*", inline_flag; word = @d_sub, 0, 0, $86
// DIV
char d_div = "/", inline_flag; word = @d_mul, 0, 0, $88
// DIVMOD
char d_divmod = "/MOD", inline_flag; word = @d_div, 0, 0, $36
// MOD
char d_mod = "MOD", inline_flag; word = @d_divmod, 0, 0, $8A
// NEG
char d_neg = "NEGATE", inline_flag; word = @d_mod, 0, 0, $90
// AND
char d_and = "AND", inline_flag; word = @d_neg, 0, 0, $94
// OR
char d_or = "OR", inline_flag; word = @d_and, 0, 0, $96
// XOR
char d_xor = "XOR", inline_flag; word = @d_or, 0, 0, $98
// COMPLEMENT
char d_complement = "COMPLEMENT", inline_flag; word = @d_xor, 0, 0, $92
// NOT
char d_not = "NOT", inline_flag; word = @d_complement, 0, 0, $80
// LEFT SHIFT
char d_lshift = "LSHIFT", inline_flag; word = @d_not, 0, 0, $9A
// RIGHT SHIFT
char d_rshift = "RSHIFT", inline_flag; word = @d_lshift, 0, 0, $9C
// EQUALS
char d_eq = "=", inline_flag; word = @d_rshift, 0, 0, $40
// NOT EQUALS
char d_ne = "<>", inline_flag; word = @d_eq, 0, 0, $42
// GREATER THAN
char d_gt = ">", inline_flag; word = @d_ne, 0, 0, $44
// LESS THAN
char d_lt = "<", inline_flag; word = @d_gt, 0, 0, $46
// UNSIGNED GREATER THAN
char d_ugt = "U>", 0; word = @d_lt, 0, @isugt
// UNSIGNED LESS THAN
char d_ult = "U<", 0; word = @d_ugt, 0, @isult
// LESS THAN ZERO
char d_0lt = "0<", inlinew_flag; word = @d_ult, 0, 0, $4600 // ZERO ISLT
// GREATER THAN ZERO
char d_0gt = "0>", inlinew_flag; word = @d_0lt, 0, 0, $4400 // ZERO ISGT
// EQUALS ZERO
char d_0eq = "0=", inlinew_flag; word = @d_0gt, 0, 0, $4000 // ZERO ISEQ
// NOT EQUAL ZERO
char d_0ne = "0<>", inlinew_flag; word = @d_0eq, 0, 0, $4200 // ZERO ISNE
// ABS
char d_abs = "ABS", 0; word = @d_0ne, 0, @_abs_
// MIN
char d_min = "MIN", 0; word = @d_abs, 0, @_min_
// MAX
char d_max = "MAX", 0; word = @d_min, 0, @_max_
// CHAR PUT
char d_cset = "C!", inline_flag | showcr_flag; word = @d_max, 0, 0, $70
// WORD PUT
char d_wset = "!", inline_flag | showcr_flag; word = @d_cset, 0, 0, $72
// WORD PLUS PUT
char d_wplusset = "+!", showcr_flag; word = @d_wset, 0, @_wplusset_
// CHAR GET
char d_cget = "C@", inline_flag; word = @d_wplusset, 0, 0, $60
// WORD GET
char d_wget = "@", inline_flag; word = @d_cget, 0, 0, $62
// EXECUTE
char d_execute = "EXECUTE", showcr_flag; word = @d_wget, 0, @_execword_
// TO RSTACK
char d_torstk = ">R", showcr_flag; word = @d_execute, 0, @_tors_
// FROM RSTACK
char d_fromrstk = "R>", 0; word = @d_torstk, 0, @_fromrs_
// TOP OF RSTACK
char d_toprstk = "R@", 0; word = @d_fromrstk, 0, @_toprs_
// PLASMA SYMBOL LOOKUP
char d_lookup = "LOOKUP", 0; word = @d_toprstk, 0, @_lookup_
// PLASMA LINKEAGE
char d_plasma = "PLASMA", interponly_flag; word = @d_lookup, 0, @_plasma_
// VARIABLE
char d_var = "VARIABLE", interponly_flag; word = @d_plasma, 0, @_var_
// CONSTANT
char d_const = "CONSTANT", interponly_flag; word = @d_var, 0, @_const_
// CMOVE
char d_cmove = "CMOVE", showcr_flag; word = @d_const, 0, @_cmove_
// MOVE
char d_move = "MOVE", showcr_flag; word = @d_cmove, 0, @_move_
// FILL
char d_fill = "FILL", showcr_flag; word = @d_cmove, 0, @_fill_
// LATEST
char d_latest = "LATEST", 0; word = @d_fill, 0, @_latest_
// HERE
char d_here = "HERE", 0; word = @d_latest, 0, @heapmark
// PAD
char d_pad = "PAD", 0; word = @d_here, 0, @_pad_
// ALLOT
char d_allot = "ALLOT", showcr_flag; word = @d_pad, 0, @_allot_
// BRANCH ( not in vocabulary )
char d_branch = "(BRANCH)", param_flag | inline_flag | showcr_flag; word = 0, 0, @_branch_, $C4
// BRANCH IF 0 ( not in vocabulary )
char d_0branch = "(0BRANCH)", param_flag | inline_flag | showcr_flag; word = 0, 0, @_0branch_, $C2
// RECURSE
char d_recurse = "RECURSE", imm_flag | componly_flag; word = @d_allot, 0, @_recurse_
// IF
char d_if = "IF", imm_flag | componly_flag; word = @d_recurse, 0, @_if_
// ELSE
char d_else = "ELSE", imm_flag | componly_flag; word = @d_if, 0, @_else_
// THEN
char d_then = "THEN", imm_flag | componly_flag; word = @d_else, 0, @_then_
// CASE
char d_case = "CASE", imm_flag | componly_flag; word = @d_then, 0, @_case_
// OF
char d_of = "OF", imm_flag | componly_flag; word = @d_case, 0, @_of_
// ENDOF
char d_endof = "ENDOF", imm_flag | componly_flag; word = @d_of, 0, @_endof_
// ENDCASE
char d_endcase = "ENDCASE", imm_flag | componly_flag; word = @d_endof, 0, @_endcase_
// COMPILED DO ( not in vocabulary )
char d_dodo = "(DO)", showcr_flag; word = 0, 0, @_dodo_
// DO
char d_do = "DO", imm_flag | componly_flag; word = @d_endcase, 0, @_do_
// LEAVE
char d_leave = "LEAVE", componly_flag | showcr_flag; word = @d_do, 0, @_leave_
// UNLOOP
char d_unloop = "UNLOOP", componly_flag; word = @d_leave, 0, @_unloop_
// COMPILED LOOP ( not in vocabulary )
char d_doloop = "(DOLOOP)", param_flag | showcr_flag; word = 0, 0, @_doloop_
// LOOP
char d_loop = "LOOP", imm_flag | componly_flag; word = @d_unloop, 0, @_loop_
// COMPILED LOOP+ ( not in vocabulary )
char d_doplusloop = "(+DOLOOP)", param_flag | showcr_flag; word = 0, 0, @_doplusloop_
// LOOP
char d_plusloop = "+LOOP", imm_flag | componly_flag; word = @d_loop, 0, @_plusloop_
// I
char d_i = "I", componly_flag; word = @d_plusloop, 0, @_toprs_
// J
char d_j = "J", componly_flag; word = @d_i, 0, @_j_
// BEGIN
char d_begin = "BEGIN", imm_flag | componly_flag; word = @d_j, 0, @_begin_
// AGAIN
char d_again = "AGAIN", imm_flag | componly_flag; word = @d_begin, 0, @_again_
// UNTIL
char d_until = "UNTIL", imm_flag | componly_flag; word = @d_again, 0, @_until_
// WHILE
char d_while = "WHILE", imm_flag | componly_flag; word = @d_until, 0, @_while_
// REPEAT
char d_repeat = "REPEAT", imm_flag | componly_flag; word = @d_while, 0, @_repeat_
// FORGET
char d_forget = "FORGET", interponly_flag; word = @d_repeat, 0, @_forget_
// CREATE
char d_create = "CREATE", showcr_flag; word = @d_forget, 0, @_create_
// RECREATE/DOES COMPILE TIME ( not in vocabulary )
char d_createdoes = "(CREATEDOES)", showcr_flag; word = 0, 0, @_itcdoes_
// DOES
char d_does = "DOES>", imm_flag | componly_flag; word = @d_create, 0, @_does_
// COMMA
char d_comma = ",", showcr_flag; word = @d_does, 0, @_dictaddw_
// CHAR COMMA
char d_commab = "C,", showcr_flag; word = @d_comma, 0, @_dictaddb_
// STATE
char d_state = "STATE", 0; word = @d_commab, 0, @_state_
// COLON
char d_colon = ":", interponly_flag; word = @d_state, 0, @_colon_
// NONAME
char d_noname = ":NONAME", interponly_flag; word = @d_colon, 0, @_noname_
// DEFER
char d_defer = "DEFER", interponly_flag; word = @d_noname, 0, @_defer_
// IS
char d_is = "IS", interponly_flag; word = @d_defer, 0, @_is_
// COMP OFF
char d_compoff = "[", imm_flag | componly_flag; word = @d_is, 0, @_compoff_
// COMP ON
char d_compon = "]", interponly_flag; word = @d_compoff, 0, @_compon_
// COMPILE WORD ON STACK
char d_compword = "COMPILE,", componly_flag; word = @d_compon, 0, @_compword_
// POSTPONE (COMPILE) NEXT WORD
char d_postpone = "POSTPONE", imm_flag | componly_flag; word = @d_compword, 0, @_postpone_
// COMPILE ONLY
char d_componly = "COMPONLY", imm_flag; word = @d_postpone, 0, @_componly_
// INTERPRET ONLY
char d_interponly = "INTERPONLY", imm_flag; word = @d_componly, 0, @_interponly_
// IMMEDIATE
char d_immediate = "IMMEDIATE", imm_flag; word = @d_interponly, 0, @_immediate_
// EXIT
char d_exit = "EXIT", imm_flag | componly_flag; word = @d_immediate, 0, @_exit_
// SEMI
char d_semi = ";", imm_flag | componly_flag; word = @d_exit, 0, @_semi_
// COUNT
char d_count = "COUNT", 0; word = @d_semi, 0, @_count_
// FIND
char d_find = "FIND", 0; word = @d_count, 0, @_find_
// TICK
char d_tick = "'", imm_flag; word = @d_find, 0, @_tick_
// INLINE LITERAL NUMBER ( not in vocabulary )
char d_lit = "LIT", param_flag; word = 0, 0, @_lit_
// COMPILED LITERAL VALUE FROM STACK
char d_literal = "LITERAL", imm_flag | componly_flag; word = @d_tick, 0, @_compliteral_
// KEY?
char d_keypressed = "KEY?", 0; word = @d_literal, 0, @_keypressed_
// KEY
char d_key = "KEY", 0; word = @d_keypressed, 0, @_key_
// ACCEPT
char d_accept = "ACCEPT", 0; word = @d_key, 0, @_accept_
// WORD
char d_word = "WORD", 0; word = @d_accept, 0, @_word_
// _isnum_
char d__isnum_ = "NUM?", 0; word = @d_word, 0, @_isnum_
// -TRAILING
char d_trailing = "-TRAILING", 0; word = @d__isnum_, 0, @_trailing_
// COMPARE
char d_compare = "COMPARE", 0; word = @d_trailing, 0, @_compare_
// PRINT @TOS
char d_prat = "?", 0; word = @d_compare, 0, @_prat_
// PRINT TOS
char d_prtos = ".", 0; word = @d_prat, 0, @_prval_
// PRINT TOS HEX
char d_prtoshex = "$.", 0; word = @d_prtos, 0, @_prhex_
// PRINT TOS HEX BYTE
char d_prtosbyte = "C$.", 0; word = @d_prtoshex, 0, @_prbyte_
// PRINT TOS BINARY
char d_prtosbinw = "%.", 0; word = @d_prtosbyte, 0, @_prbinw_
// PRINT TOS BINARY BYTE
char d_prtosbin = "C%.", 0; word = @d_prtosbinw, 0, @_prbin_
// EMIT
char d_emit = "EMIT", 0; word = @d_prtosbin, 0, @putc
// CR
char d_cr = "CR", showcr_flag; word = @d_emit, 0, @putln
// SPACE
char d_space = "SPACE", 0; word = @d_cr, 0, @_space_
// SPACES
char d_spaces = "SPACES", 0; word = @d_space, 0, @_spaces_
// TYPE
char d_type = "TYPE", 0; word = @d_spaces, 0, @_type_
// BLANK
char d_blank = "BL", imm_flag; word = @d_type, 0, @_blank_
// CHAR
char d_char = "CHAR", imm_flag; word = @d_blank, 0, @_char_
// STRING
char d_str = "\"", imm_flag; word = @d_char, 0, @_str_
// LITERAL STRING ( not in vocabulary )
char d_slit = "SLIT", param_flag | inline_flag; word = 0, 0, @_slit_, $2E
// PRINT STRING FROM STACK
char d_doprstr = "(.\")", 0; word = @d_str, 0, @puts
// PRINT STRING
char d_prstr = ".\"", imm_flag; word = @d_doprstr, 0, @_prstr_
// PRINT PAREN STRING
char d_prpstr = ".(", imm_flag; word = @d_prstr, 0, @_prpstr_
// READ SOURCE FILE FROM STACK
char d_src = "SRC", showcr_flag; word = @d_prpstr, 0, @_src_
// READ SOURCE FILE FROM INPUT
char d_srcstr = "SRC\"", imm_flag; word = @d_src, 0, @_srcstr_
// IF END SOURCE FILE
char d_ifendsrc = "?ENDSRC", showcr_flag; word = @d_srcstr, 0, @_ifendsrc_
// END SOURCE FILE
char d_endsrc = "ENDSRC", showcr_flag; word = @d_ifendsrc, 0, @_endsrc_
// CONTINUE AFTER BRK
char d_cont = "CONT", interponly_flag; word = @d_endsrc, 0, @_cont_
// QUIT
char d_quit = "QUIT", showcr_flag; word = @d_cont, 0, @_quit_
// ABORT IF <> 0
char d_abort = "?ABORT", showcr_flag; word = @d_quit, 0, @_abort_
// DOABORTSTR
char d_doabortstr = "(?ABORT\")", showcr_flag; word = @d_abort, 0, @_doabortstr_
// ABORTSTR
char d_abortstr = "?ABORT\"", imm_flag; word = @d_doabortstr, 0, @_abortstr_
// COLD exitforth
char d_exitforth = "COLD", showcr_flag; word = @d_abortstr, 0, @_restart_
// COMMENT
char d_comment = "(", imm_flag; word = @d_exitforth, 0, @_comment_
//
// PLFORTH custom words
//
// BYE
char d_bye = "BYE", 0; word = @d_comment, 0, @_bye_
// SEE DEFINITION
char d_see = "SEE", interponly_flag; word = @d_bye, 0, @_see_
// PRINT STACK
char d_prstack = ".S", showcr_flag; word = @d_see, 0, @_prstack_
// PRINT RSTACK
char d_prrstack = ".RS", showcr_flag; word = @d_prstack, 0, @_prrstack_
// TRACE ON
char d_tron = "TRON", showcr_flag; word = @d_prrstack, 0, @_tron_
// TRACE OFF
char d_troff = "TROFF", showcr_flag; word = @d_tron, 0, @_troff_
// SINGLE STEP ON
char d_stepon = "STEPON", showcr_flag; word = @d_troff, 0, @_stepon_
// SINGLE STEP OFF
char d_stepoff = "STEPOFF", showcr_flag; word = @d_stepon, 0, @_stepoff_
// BREAK OUT
char d_brk = "BRK", showcr_flag; word = @d_stepoff, 0, @_brk_
// BREAK ON
char d_brkon = "BRKON", interponly_flag; word = @d_brk, 0, @_brkon_
// BREAK OFF
char d_brkoff = "BRKOFF", interponly_flag; word = @d_brkon, 0, @_brkoff_
//  COMPILE USING ITC
char d_itc = "ITC", interponly_flag; word = @d_brkoff, 0, @_itc_
// COMPILE USING PLASMA BYTECODES
char d_pbc = "PBC", interponly_flag; word = @d_itc, 0, @_pbc_
//
// Start of vocabulary
//
// LIST VOCAB WORDS
char d_words = "WORDS", showcr_flag; word = @d_pbc, 0, @_words_
//
// Machine code helper routines
//
asm _get_estackdepth#1
        !SOURCE "vmsrc/plvmzp.inc"
        TXA
        EOR     #$FF
        SEC
        ADC     #ESTKSZ/2
        CMP     #ESTKSZ/2+1
        BCC     +
        LDX     #ESTKSZ/2
+       DEX
        STA     ESTKL,X
        LDA     #$00
        STA     ESTKH,X
        RTS
end
asm _get_estack(index)#1
        LDA     #ESTKSZ/2
        CLC
        SBC     ESTKL,X
        TAY
        LDA     ESTKL,Y
        STA     ESTKL,X
        LDA     ESTKH,Y
        STA     ESTKH,X
        RTS
end
asm _reset_estack#0
        LDX     #ESTKSZ/2
end
asm _push(a)#0 // Stack hack - call as _push(a)to leave a on eval stack
        RTS
end
//def _ffa_(dentry)#1
//  return dentry + ^dentry + 1
//end
asm _ffa_(dentry)#1
        LDA     ESTKL,X
        STA     ESTKH-1,X
        LDA     (ESTKH-1,X)
        SEC
        ADC     ESTKL,X
        STA     ESTKL,X
        BCC     +
        INC     ESTKH,X
+       RTS
end
//def _pfa_(dentry)#1
//  return dentry + ^dentry + 8
//end
asm _pfa_(dentry)#1
        LDY     #$08
        BNE     +
end
//def _hfa_(dentry)#1
//  return dentry + ^dentry + 4
//end
asm _hfa_(dentry)#1
        LDY     #$04
        BNE     +
end
//def _lfa_(dentry)#1
//  return dentry + ^dentry + 2
//end
asm _lfa_(dentry)#1
        LDY     #$02
        BNE     +
end
//def _cfa_(dentry)#1
//  return dentry + ^dentry + 6
//end
asm _cfa_(dentry)#1
        LDY     #$06
+       LDA     ESTKL,X
        STA     ESTKH-1,X
        TYA
        CLC
        ADC     (ESTKH-1,X)
        ADC     ESTKL,X
        STA     ESTKL,X
        BCC   +
        INC     ESTKH,X
        CLC
+       RTS
end
//def hashname(chars, len)#1
//  return (len ^ ((^chars << 1) ^ ^(chars + len / 2) << 2)) & HASH_MASK
//end
asm hashname(chars, len)#1
        LDA     ESTKL+1,X
        STA     SRCL
        LDA     ESTKH+1,X
        STA     SRCH
        LDA     ESTKL,X
        LSR
        TAY
        LDA     (SRC), Y
        ASL
        ASL
        EOR     ESTKL,X
        STA     ESTKL,X
        LDY     #$00
        LDA     (SRC),Y
        ASL
        EOR     ESTKL,X
        AND     #63           ; HASH_MASK
        INX
        STA     ESTKL,X
        STY     ESTKH,X
        RTS
end
//
// Helper routines
//
def _dictaddw_(a)#0
  *(heapalloc(2)) = a
end
def _dictaddb_(a)#0
  ^(heapalloc(1)) = a
end
//
// Input routines
//
def keyin#0
  byte i

  repeat
    puts(brk ?? " BRK\n" :: " OK\n")
    memcpy(keyinbuf, gets(state & comp_flag ?? ']'|$80 :: '>'|$80), INBUF_SIZE)
    inptr = keyinbuf // Reset inptr to beginning of buffer
  until ^inptr
  if ^inptr > INBUF_SIZE-1
    ^inptr = INBUF_SIZE-1
  fin
  ^(inptr + ^inptr + 1) = 0 // NULL terminate
  inptr++
end
def endsrc#1
  if srclevel > 0
    srclevel--
    fileio:close(inref[srclevel]) // EOF
    inref[srclevel] = 0
    inbufptr        = inbufptr - INBUF_SIZE
    inptr           = previnptr[srclevel]
    if srclevel == 0              // - switch back to keyboard input
        infunc = @keyin
        //keyin
    fin
  fin
  return srclevel == 0
end
def filein#0
  byte len
  repeat
      len = fileio:read(inref[srclevel-1], inbufptr, INBUF_SIZE-1)
      if len
        if ^(inbufptr + len - 1) == $0D
          len-- // Remove trailing carriage return
        fin
        ^(inbufptr + len) = 0 // NULL terminate
        inptr             = inbufptr
      else
        if endsrc
          return
        fin
      fin
    until len
end
def nextword(delim)#2
  word wordptr
  byte len

  repeat
    if !^inptr
      infunc()#0
    fin
    while ^inptr == delim // Skip leading delimiter
      inptr++
    loop
  until ^inptr
  wordptr = inptr
  while ^inptr and ^inptr <> delim // Tokenize characters
    inptr++
  loop
  len = inptr - wordptr
  if ^inptr // Skip trailing delimiter
    inptr++
  fin
  return wordptr, len
end
//
// Hash table routines
//
def addhash(dentry)#0
  byte hash

  hash           = hashname(dentry + 1, ^dentry)
  *_hfa_(dentry) = hashtbl[hash]
  hashtbl[hash]  = dentry
end
def buildhashtbl#0
  word dentry
  byte hash

  memset(@hashtbl, 0, HASH_SIZE * 2)
  dentry = latest
  while dentry
    hash           = hashname(dentry + 1, ^dentry)
    *_hfa_(dentry) = hashtbl[hash]
    hashtbl[hash]  = dentry
    dentry         = *_lfa_(dentry)
  loop
end
//
// Warm start
//
def warmstart#0
  _reset_estack()
  brk    = 0
  brkcfa = 0
  RSP    = RSTK_SIZE
  if state & comp_flag // Undo compilation state
    heaprelease(latest)
    latest = *_lfa_(latest)
  fin
  state = 0
  while !endsrc; loop
  infunc = @keyin
  inptr  = keyinbuf
  ^inptr = 0
end
//
// Cold start
//
def coldstart#0
  warmstart
  latest = @d_words
  heaprelease(startheap)
  buildhashtbl
end
//
// Find match in dictionary
//
def find(matchchars, matchlen)#1
  word dentry
  byte i

  for i = 0 to matchlen-1
    ^(matchchars + i) = toupper(^(matchchars + i))
  next
  dentry = hashtbl[hashname(matchchars, matchlen)]
  matchchars--
  while dentry
    if ^dentry == matchlen
      for i = matchlen downto 1
        if ^(matchchars + i) <> ^(dentry + i)
          break
        fin
      next
      if i == 0
        return dentry
      fin
    fin
    dentry = *_hfa_(dentry)
  loop
  return 0 // Not found
end
//
// Convert input into number
//
def _isnum_(numchars, numlen)#2
  word num, sign
  byte numchar

  sign = 1
  if ^numchars == '-'
    sign = -1
    numchars++
    numlen--
    if numlen == 0
      return 0, 0
    fin
  fin
  num = 0
  if ^numchars == '$' // Hexadecimal
    numchars++
    numlen--
    if numlen == 0
      return 0, 0
    fin
    while numlen
      numchar = toupper(^numchars)
      if numchar >= '0' and numchar <= '9'
        num = num * 16 + numchar - '0'
      elsif numchar >= 'A' and numchar <= 'F'
        num = num * 16 + numchar - 'A' + 10
      else
        break
      fin
      numchars++
      numlen--
    loop
  elsif ^numchars == '%' // Binary
    numchars++
    numlen--
    if numlen == 0
      return 0, 0
    fin
    while numlen
      numchar = ^numchars
      if numchar == '0' or numchar == '1'
        num = num * 2 + numchar - '0'
      else
        break
      fin
      numchars++
      numlen--
    loop
  else
    while numlen
      numchar = ^numchars
      if numchar < '0' or numchar > '9'
        break
      fin
      num = num * 10 + numchar - '0'
      numchars++
      numlen--
    loop
  fin
  return num * sign, numlen == 0
end
//
// Break handler
//
def showtrace(dentry)#0
    putln; puts("( "); _prstack_; puts(") "); puts(dentry); putc(' ')
end
def brkhandle(dentry)#0
  word brk_infn, brk_inptr, brk_iip
  byte brk_state
  char brk_inbuf[INBUF_SIZE + 1]

  showtrace(dentry)
  brk_iip   = IIP
  brk_infn  = infunc
  brk_inptr = inptr
  memcpy(@brk_inbuf, keyinbuf, INBUF_SIZE + 1)
  infunc    = @keyin
  inptr     = keyinbuf
  ^inptr    = 0
  brk_state = state &  comp_flag
  state     = state & ~comp_flag
  brk++
  _interpret_
  brk--
  state     = brk_state | state
  IIP       = brk_iip
  infunc    = brk_infn
  inptr     = brk_inptr
  memcpy(keyinbuf, @brk_inbuf, INBUF_SIZE + 1)
end
//
// Execute code in CFA
//
def _execword_(dentry)#0
  when conio:keypressed()
    is $83 // CTRL-C
      conio:getkey() // Clear KB
      brkhandle(dentry)
      break
    is $94 // CTRL-T
      conio:getkey() // Clear KB
      state = state ^ trace_flag
      break
  wend
  if state & trace_flag
    showtrace(dentry)
    if state & step_flag
      if conio:getkey() == $03 // CTRL-C
        brkhandle(dentry)
      fin
    fin
  fin
  W = _cfa_(dentry)
  (*W)()#0
  if _get_estackdepth() > 32
    puts("Stack over/underflow\n")
    _quit_
  fin
end
def execwords(wlist)#0
  word prevIP, dentry

  prevIP = IIP
  IIP    = wlist
  dentry = *IIP
  while dentry
    IIP    = IIP + 2
    _execword_(dentry)
    dentry = *IIP
  loop
  IIP = prevIP
end
//
// Compile a word/literal into the dictionary: ITC and PBC
//
def _compword_(dentry)#0
  if ^_ffa_(dentry) & interponly_flag
    puts("INTERP only word\n")
    _quit_
  elsif state & comp_itc_flag
    _dictaddw_(dentry)
  else // comp_pbc_flag
    if ^_ffa_(dentry) & itc_flag // Check if calling ITC word
      _dictaddb_($2C)    // CONSTANT WORD
      _dictaddw_(dentry) // Pointer to dictionary entry
      _dictaddb_($54)    // CALL _execword_
      _dictaddw_(@_execword_)
    elsif ^_ffa_(dentry) & inline_flag // inline bytecode
      _dictaddb_(^_pfa_(dentry))
    elsif ^_ffa_(dentry) & inlinew_flag // inline 2 bytecodes
      _dictaddw_(*_pfa_(dentry))
    else
      _dictaddb_($54) // CALL CFA directly
      _dictaddw_(*_cfa_(dentry))
    fin
  fin
  if state & trace_flag
    putc('['); puts(dentry); puts("] ")
  fin
end
def _compliteral_(value)#0
  if state & comp_itc_flag
    _dictaddw_(@d_lit)
    _dictaddw_(value) // Poke literal value into dictionary
  else // comp_pbc_flag
    if value >= 0 and value <= 255
      if value <= 15
        _dictaddb_(value << 1) // CONSTANT NIBBLE
      else
        _dictaddb_($2A) // CONSTANT BYTE
        _dictaddb_(value) // Poke literal value into dictionary
      fin
    elsif value < 0 and value >= -256
      if value == -1
        _dictaddb_($20) // CONSTANT MINUS_ONE
      else
        _dictaddb_($5E) // CONSTANT NEGATIVE BYTE
        _dictaddb_(value) // Poke literal value into dictionary
      fin
    else
      _dictaddb_($2C) // CONSTANT WORD
      _dictaddw_(value) // Poke literal value into dictionary
    fin
  fin
end
def _interpret_#0
  word inchars, dentry, value
  byte inlen, valid

  //
  // Set flags on words
  //
  repeat
    inchars, inlen = nextword(' ')
    dentry = find(inchars, inlen)
    if dentry
      if not (state & comp_flag) or (^_ffa_(dentry) & imm_flag)
        if not (state & comp_flag) and (^_ffa_(dentry) & componly_flag)
          puts(dentry)
          puts(" : Compile only word\n")
          _quit_
        fin
        _execword_(dentry)
      else
        _compword_(dentry)
      fin
    else
      value, valid = _isnum_(inchars, inlen)
      if valid
        if state & comp_flag
          _compliteral_(value)
        else
          _push(value)
        fin
      else
        inchars--
        ^inchars = inlen
        puts(inchars)
        puts(" ? No match\n")
        if !brk; warmstart; fin
      fin
    fin
  until state & exit_flag
  state = state & ~exit_flag
end
//
// Intrinsics
//
def _swap_(a,b)#2
  return b,a
end
def _ifdup_(a)#1
  if a; _push(a); fin
  return a
end
def _dup2_(a,b)#4
  return a,b,a,b
end
def _over_(a,b)#3
  return a,b,a
end
def _rot_(a,b,c)#3
  return b,c,a
end
def _wplusset_(a,b)#0
  *b = *b + a
end
def _abs_(a)#1
  return a < 0 ?? -a :: a
end
def _min_(a,b)#1
  return a > b ?? b :: a
end
def _max_(a,b)
  return a > b ?? a :: b
end
def _tors_(a)#0
  if RSP == 0
    puts("Return stack overflow\n")
    _quit_
  fin
  RSP--
  RSTACK[RSP] = a
end
def _fromrs_#1
  if RSP == RSTK_SIZE
    puts("Return stack underflow\n")
    _quit_
  fin
  RSP++
  return RSTACK[RSP - 1]
end
def _toprs_#1
  return RSTACK[RSP]
end
def _lit_#1
  word lit

  lit = *IIP
  IIP = IIP + 2
  return lit
end
def _slit_#1
  word slit

  slit = IIP
  IIP  = IIP + ^IIP + 1
  return slit
end
def _allot_(a)#0
  heapalloc(a)
end
def _cmove_(a,b,c)#0
  memcpy(b, a, c)
end
def _move_(a,b,c)#0
  memcpy(b, a, c * 2)
end
def _fill_(a,b,c)#0
  memset(a, c | (c << 8), b)
end
def _pad_#1
  return heapmark + 768 // Make sure to avoid JIT heap usage
end
def _trailing_(a,b)#2
  while b and ^(a + b - 1) == ' '
    b--
  loop
  return a, b
end
def _compare_(a,b,c,d)#1
  byte i, l

  l = b < d ?? b :: d
  for i = 0 to l - 1
    if ^(a + i) <> ^(c + i)
      return ^(a + i) < ^(c + i) ?? -1 :: 1
    fin
  next
  if    b < d return -1
  elsif b > d return 1
  fin
  return 0
end
def _latest_#1
  return latest
end
def newdict#0
  word plist, namechars, namelen
  byte i

  namechars, namelen = nextword(' ')
  plist  = latest
  latest = heapalloc(namelen + 8)
  for i = 0 to namelen-1
    ^(latest + i + 1) = toupper(^(namechars + i))
  next
  //memcpy(latest + 1, namechars, namelen)
  ^latest        = namelen
  ^_ffa_(latest) = 0
  *_lfa_(latest) = plist
  *_hfa_(latest) = 0
  *_cfa_(latest) = _pfa_(latest)
end
def _plasma_(a)#0
  newdict
  ^_ffa_(latest) = showcr_flag
  *_cfa_(latest) = a // PLASMA code address
  addhash(latest)
end
def _var_(a)#0
  newdict
  _dictaddb_(JSR); _dictaddw_(vmvect)
  _dictaddb_($2C)          // CONSTANT WORD
  _dictaddw_(heapmark + 3) // Poiner to variable in PFA
  _dictaddb_($5C)          // RET
  _dictaddw_(a)            // Variable storage
  addhash(latest)
end
def _const_(a)#0
  newdict
  _dictaddb_(JSR); _dictaddw_(vmvect)
  _dictaddb_($2C)          // CONSTANT WORD
  _dictaddw_(a)
  _dictaddb_($5C)          // RET
  addhash(latest)
end
def _create_#0
  newdict
  _dictaddb_(JSR); _dictaddw_(vmvect)
  _dictaddb_($2C)          // CONSTANT WORD
  _dictaddw_(heapmark + 5) // Pointer to rest of PFA
  _dictaddb_($5C)          // RET
  _dictaddw_(0)            // reserved word for DOES>
  addhash(latest)
  //
  // 9 bytes after PFA, data follows...
  //
end
def _state_#1
  return state & comp_flag
end
def _dodoes_#0
  _push(W + 11)   // Pointer to PFA storage
  execwords(*(W + 2)) // Exec PFA ptr
end
def _itcdoes_(a)#0
  //
  // Overwrite CREATE as ITC words
  //
  ^_ffa_(latest) = ^_ffa_(latest) | itc_flag
  *_cfa_(latest) = @_dodoes_
  *_pfa_(latest) = a // Fill in DOES code address
end
def _pbcdoes_(a)#0
  //
  // Rewrite the end of CREATE
  //
  ^(_pfa_(latest) + 6) = $C4    // JUMP DOES> directly
  *(_pfa_(latest) + 7) = a
end
def _does_#0
  if state & comp_itc_flag
    _dictaddw_(@d_lit)
    _dictaddw_(heapmark + 8) // Pointer to DOES code
    _dictaddw_(@d_createdoes)
    _dictaddw_(0)            //  Double zero for SHOW
    _dictaddw_(0)
    // End of <BUILDS, beginning of DOES>
  else // comp_pbc_flag
    _dictaddb_($2C)           // CONSTANT WORD
    _dictaddw_(heapmark + 6)  // Pointer to DOES code
    _dictaddb_($54)           // CALL
    _dictaddw_(@_pbcdoes_)    // Fills in code address reserved in _compbuilds_
    _dictaddb_($5C)           // RET
    // End of <BUILDS, beginning of DOES> code
  fin
end
def _dodefer_#0
  _execword_(*(W + 2)) // Exec deferred word
end
def _defer_#0
  newdict
  _dictaddb_(RTS);  _dictaddw_(0) // NO-OP and space for deferred pfa
  addhash(latest)
end
def _is_(a)#0
  word dentry

  dentry = find(nextword(' '))
  if dentry
    ^_ffa_(dentry) = ^_ffa_(a)
    if ^_ffa_(dentry) & itc_flag
      *_cfa_(dentry) = @_dodefer_
      *_pfa_(dentry) = a
    else // comp_pbc_flag
      *_cfa_(dentry)       = _pfa_(dentry)
      ^_pfa_(dentry)       = JMP
      *(_pfa_(dentry) + 1) = *_cfa_(a)
    fin
  else
    puts(a); puts(" Not found")
    _quit_
  fin
end
def _docolon_#0
  execwords(W + 2) // Exec PFA
end
def _colon_#0
  newdict
  state = state | comp_mode
  if state & comp_itc_flag
    ^_ffa_(latest) = itc_flag | showcr_flag
    *_cfa_(latest) = @_docolon_
  else // comp_pbc_flag
    ^_ffa_(latest) = showcr_flag
    _dictaddb_(JSR); _dictaddw_(vmvect)
  fin
  if state & trace_flag
    puts(latest); putc(' ')
  fin
end
def _noname_#0
  word plist
 
  plist          = latest
  latest         = heapalloc(8)
  ^latest        = 0
  *_lfa_(latest) = plist
  *_hfa_(latest) = 0
  state          = state | comp_mode
  if state & comp_itc_flag
    ^_ffa_(latest) = itc_flag | showcr_flag
    *_cfa_(latest) = @_docolon_
  else // comp_pbc_flag
    ^_ffa_(latest) = showcr_flag
    *_cfa_(latest) = _pfa_(latest)
    _dictaddb_(JSR); _dictaddw_(vmvect)
  fin
  if state & trace_flag
    puts(latest); putc(' ')
  fin
end
def _exit_#0
  if state & comp_itc_flag
    _dictaddw_(0)
  elsif state & comp_pbc_flag
    _dictaddb_($5C) // RET
  fin
end
def _semi_#0
  _exit_
  if state & comp_itc_flag // Add double zero at end of definition for SHOW
    _dictaddw_(0)
  fin
  if ^latest
    addhash(latest) // COLON definition
  else
    _push(latest) // NONAME definition
  fin
  state = state & ~comp_flag
end
def _postpone_#0
  word dentry

  dentry = find(nextword(' '))
  if dentry
    _compword_(dentry)
  else
    puts("No match\n")
    _quit_
  fin
end
def _compoff_#0
  state = state & ~comp_flag
end
def _compon_#0
  state = state | comp_mode
end
def _componly_#0
  ^_ffa_(latest) = ^_ffa_(latest) | componly_flag
end
def _interponly_#0
  ^_ffa_(latest) = ^_ffa_(latest) | interponly_flag
end
def _immediate_#0
  ^_ffa_(latest) = ^_ffa_(latest) | imm_flag
end
def _branch_#0
  IIP = *IIP
end
def _0branch_(a)#0
  if a
    IIP = IIP + 2
  else
    IIP = *IIP
  fin
end
def _recurse_#0
  _compword_(latest)
end
def _if_#0
  _compword_(@d_0branch)
  _tors_(heapalloc(2)) // Save backfill address
end
def _else_#0
  word backref

  backref = _fromrs_
  _compword_(@d_branch)
  _tors_(heapalloc(2))
  *backref = heapmark
end
def _then_#0
  *_fromrs_ = heapmark
end
def _case_#0
  _compword_(@d_dup)
  _tors_(0) // Linked address list
end
def _of_#0
  if state & comp_itc_flag
    _dictaddw_(@d_eq)
    _dictaddw_(@d_0branch)
  else // comp_pbc_flag
    _dictaddb_($24) // BRNE
  fin
  _tors_(heapalloc(2)) // Save backfill address
end
def _endof_#0
  word backref, link

  backref = _fromrs_
  link    = _fromrs_
  _compword_(@d_branch)
  _tors_(heapmark)
  _dictaddw_(link)
  if state & comp_itc_flag
    *backref = heapmark
  else // comp_pbc_flag
    *backref = heapmark - backref // Relative branch
  fin
  _compword_(@d_dup)
end
def _endcase_#0
  word backref, link

  _compword_(@d_drop)
  backref = _fromrs_
  while backref
    link     = *backref
    *backref = heapmark
    backref  = link
  loop
  _compword_(@d_drop)
end
def _dodo_(a,b)#0
  if RSP < 2
    puts("Return stack overflow\n")
    _quit_
  fin
  RSP             = RSP - 2
  RSTACK[RSP + 1] = a
  RSTACK[RSP]     = b
end
def _do_#0
  _compword_(@d_dodo)
  _tors_(heapmark)
end
def _leave_#0
  RSTACK[RSP] = RSTACK[RSP + 1] - 1
end
def _doloop_#0
  RSTACK[RSP]++
  if RSTACK[RSP] == RSTACK[RSP + 1]
    RSP = RSP + 2
    IIP = IIP + 2
  else
    IIP = *IIP
  fin
end
def _dopbcloop_#1
  RSTACK[RSP]++
  if RSTACK[RSP] == RSTACK[RSP + 1]
    RSP = RSP + 2
    return TRUE
  fin
  return FALSE
end
def _doplusloop_(a)#0
  RSTACK[RSP] = RSTACK[RSP] + a
  if (a >= 0 and RSTACK[RSP] >= RSTACK[RSP + 1]) or (a < 0 and RSTACK[RSP] <= RSTACK[RSP + 1])
    RSP = RSP + 2
    IIP = IIP + 2
  else
    IIP = *IIP
  fin
end
def _dopbcplusloop_(a)#1
  RSTACK[RSP] = RSTACK[RSP] + a
  if (a >= 0 and RSTACK[RSP] >= RSTACK[RSP + 1]) or (a < 0 and RSTACK[RSP] <= RSTACK[RSP + 1])
    RSP = RSP + 2
    return TRUE
  fin
  return FALSE
end
def _loop_#0
  if state & comp_itc_flag
    _dictaddw_(@d_doloop)
  else // comp_pbc_flag
    _dictaddb_($54) // CALL
    _dictaddw_(@_dopbcloop_)
    _dictaddb_($C2) // JUMPZ
  fin
    _dictaddw_(_fromrs_)
end
def _plusloop_#0
  if state & comp_itc_flag
    _dictaddw_(@d_doplusloop)
  else // comp_pbc_flag
    _dictaddb_($54) // CALL
    _dictaddw_(@_dopbcplusloop_)
    _dictaddb_($C2) // JUMPZ
  fin
    _dictaddw_(_fromrs_)
end
def _unloop_#0
  if RSP > RSTK_SIZE-1
    puts("Return stack underflow\n")
    _quit_
  fin
  RSP = RSP + 2
end
def _j_#1
  return RSTACK[RSP + 2]
end
def _begin_#0
  _tors_(heapmark)
end
def _again_#0
  _compword_(@d_branch)
  _dictaddw_(_fromrs_)
end
def _until_#0
  _compword_(@d_0branch)
  _dictaddw_(_fromrs_)
end
def _while_#0
  _compword_(@d_0branch)
  _tors_(heapalloc(2)) // Save backfill address
end
def _repeat_#0
  word backref

  backref = _fromrs_ // Backref from WHILE
  _compword_(@d_branch)
  _dictaddw_(_fromrs_)
  *backref = heapmark // Backref to BEGIN
end
def _count_(a)#2
  return a + 1, ^a
end
def _find_(a)#2
  word dentry

  dentry = find(_count_(a))
  if dentry
    return dentry, ^_ffa_(dentry) & imm_flag ?? 1 :: -1
  fin
  return a, 0
end
def _tick_#0
  word dentry

  dentry = find(nextword(' '))
  if state & comp_flag
    _compliteral_(dentry)
  else
    _push(dentry)
  fin
end
def _forget_#0
  word dentry

  dentry = find(nextword(' '))
  if dentry
    if isult(dentry, startheap)
      latest = @d_words
      dentry = startheap
    else
      latest = *_lfa_(dentry)
    fin
    heaprelease(dentry)
    buildhashtbl
  else
    puts("No match\n")
    _quit_
  fin
end
def _accept_(a,b)#1
  word saveinptr
  byte len

  saveinptr = inptr
  memcpy(heapmark + 256, keyinbuf, 80)
  inptr = gets('?'|$80)
  len = ^inptr
  if len > b
    len = b
  fin
  ^(inptr + len + 1) = 0
  memcpy(a, inptr + 1, len)
  memcpy(keyinbuf, heapmark + 256, 80)
  inptr = saveinptr
  return len
end
def _keypressed_#1
  return conio:keypressed() > 127
end
def _key_#1
  return conio:getkey()
end
def _word_(a)#1
  word wordptr
  byte len

  wordptr, len = nextword(a)
  wordptr--
  ^wordptr = len
  return wordptr
end
def _space_#0
    putc(' ')
end
def _spaces_(a)#0
    while a
        putc(' ')
        a--
    loop
end
def _prval_(a)#0
  puti(a); putc(' ')
end
def _prbyte_(a)#0
  putc('$'); putb(a); putc(' ')
end
def _prhex_(a)#0
  putc('$'); puth(a); putc(' ')
end
def _prbin_(a)#0
  byte i
  putc('%')
  for i = 0 to 7
    putc(a & $80 ?? '1' :: '0')
    a = a << 1
  next
  putc(' ')
end
def _prbinw_(a)#0
  byte i
  putc('%')
  for i = 0 to 15
    putc(a & $8000 ?? '1' :: '0')
    a = a << 1
  next
  putc(' ')
end
def _prat_(a)#0
  puti(*a); putc(' ')
end
def _blank_#0
  if state & comp_flag
    _compliteral_(32)
  else
    _push(32)
  fin
end
def _char_#0
  word str
  byte len

  str, len = nextword(' ')
  if state & comp_flag
    _compliteral_(^str)
  else
    _push(^str)
  fin
end
def _str_#0
  word str
  byte len

  str, len = nextword('"')
  str--
  ^str = len
  len++
  if state & comp_flag
    _compword_(@d_slit)
    memcpy(heapalloc(len), str, len) // Add to dictionary
  else
    _push(strbuf)
    memcpy(strbuf, str, len) // Copy to internal string buffer
  fin
end
def _type_(a,b)#0
  while b and ^a
    putc(^a)
    a++
    b--
  loop
end
def _prstr_#0
  word str
  byte len

  if state & comp_flag
    _str_
    _compword_(@d_doprstr)
  else
    str, len = nextword('"')
    str--
    ^str = len
    puts(str)
  fin
end
def _prpstr_#0
  word str
  byte len

  if state & comp_flag
    _str_
    _compword_(@d_doprstr)
  else
    str, len = nextword(')')
    str--
    ^str = len
    puts(str)
  fin
end
def stodci(str, dci)
  byte len, c

  len = ^str
  if len == 0
    ^dci = 0
    return dci
  fin
  c = toupper(^(str + len)) & $7F
  len--
  ^(dci + len) = c
  while len
    c = toupper(^(str + len)) | $80
    len--
    ^(dci + len) = c
  loop
  return dci
end
def _lookup_#1
  word symname
  char symlen, dci[31]

  symname, symlen = nextword(' ')
  symname--
  ^symname = symlen
  return cmdsys:lookupsym(stodci(symname, @dci))
end
def _src_(a)#0
  char[64] syssrc

  if srclevel >= SRCREFS
    puts("Too many nested SRC")
    _quit_
  fin
  inref[srclevel] = fileio:open(a)
  if !inref[srclevel] and ^a < 16
    strcpy(@syssrc, cmdsys:syspath)
    strcat(@syssrc, "scripts/")
    strcat(@syssrc, a)
    inref[srclevel] = fileio:open(@syssrc)
  fin
  if inref[srclevel]
    fileio:newline(inref[srclevel], $7F, $0D)
    infunc               = @filein
    inbufptr             = inbuf + srclevel * INBUF_SIZE
    previnptr[srclevel]  = inptr
    inptr                = inbufptr
    ^inptr               = 0
    srclevel++
  else
    puts("Failed to open "); puts(a); putln
  fin
end
def _srcstr_#0
  word filename
  byte len

  if state & comp_flag
    _str_
    _compword_(@d_src)
  else
    filename, len = nextword('"')
    filename--
    ^filename = len
    _src_(filename)
  fin
end
def _endsrc_#0
  endsrc
end
def _ifendsrc_(a)#0
  if a
    endsrc
  fin
end
def _see_#0
  word dentry, pfa, w

  dentry = find(nextword(' '))
  if dentry
    putc('$'); puth(dentry); putc(' '); puts(dentry)
    if ^_ffa_(dentry) & imm_flag; puts(" IMMEDIATE"); fin
    if ^_ffa_(dentry) & componly_flag; puts(" COMPILE-ONLY"); fin
    if ^_ffa_(dentry) & interponly_flag; puts(" INTERPRET-ONLY"); fin
    putln
    if ^_ffa_(dentry) & itc_flag // Only show ITC words
      puts("-----\n")
      when *_cfa_(dentry)
        is @_docolon_
          pfa = _pfa_(dentry)
          break
        is @_dodefer_
          pfa = _pfa_(*_pfa_(dentry))
          break
        is @_dodoes_
         pfa = *_pfa_(dentry)
          break
        otherwise // ???
         pfa = @d_exit
      wend
      putc('$'); puth(pfa); putc(' ')
      w = *pfa
      while w
        if ^_ffa_(w) & param_flag
          pfa = pfa + 2
          when w
            is @d_slit
              putc('"')
              puts(pfa)
              putc('"')
              pfa = pfa + ^pfa - 1
              break
            is @d_lit
              puti(*pfa)
              break
            is @d_branch
            is @d_0branch
            is @d_doloop
              puts(w); puts(" $"); puth(*pfa)
              break
            otherwise
              puts(w)
          wend
        else
          puts(w)
        fin
        pfa = pfa + 2
        if ^_ffa_(w) & showcr_flag
          putln; putc('$'); puth(pfa)
        fin
        putc(' ')
        w = *pfa
        if !w
          pfa = pfa + 2
          w = *pfa
          if w; puts("EXIT\n"); putc('$'); puth(pfa); putc(' '); fin // Early exit
        fin
        if conio:keypressed()
          conio:getkey(); conio:getkey()
        fin
      loop
      puts("EXIT\n")
    fin
  fin
end
def _prstack_#0
  byte index, depth
  depth = _get_estackdepth()
  index = 0
  while index < depth
    puti(_get_estack(index)); putc(' ')
    index++
  loop
end
def _prrstack_#0
  byte depth

  depth = RSTK_SIZE - 1
  while depth >= RSP
    puti(RSTACK[depth]); putc(' ')
    depth--
  loop
end
def _tron_#0
  state = state | trace_flag
end
def _troff_#0
  state = state & ~(trace_flag | step_flag)
end
def _stepon_#0
  state = state | step_flag | trace_flag
end
def _stepoff_#0
  state = state & ~step_flag
end
def brkpoint#0
  brkhandle(brkentry)
  W = _cfa_(brkentry)
  if brkcfa
    brkcfa()#0
  else // Breakpoint was cleared
    (*_cfa_(brkentry))()#0
  fin
end
def _brk_#0
  brkhandle(@d_brk)
end
def _brkon_#0
  word dentry

  if brkcfa
    puts("Breakpoint already enabled\n")
  else
    dentry = find(nextword(' '))
    if dentry
      brkentry = dentry
      brkcfa = *_cfa_(dentry)
      *_cfa_(dentry) = @brkpoint
    else
      puts("No match\n")
    fin
  fin
end
def _brkoff_#0
  *_cfa_(brkentry) = brkcfa
  brkcfa           = 0
end
def _cont_#0
  if brk
    state = state | exit_flag
  else
    putc('?')
  fin
end
def _itc_#0
  comp_mode = comp_itc_flag
end
def _pbc_#0
  comp_mode = comp_pbc_flag
end
def _comment_#0
  nextword(')')
end
def typelist(typestr, typemask, type)#0
  word d
  byte tab, width

  width = cmdsys:_sysflags_ & vid80col ?? 79 :: 39
  puts(typestr)
  tab = ^typestr
  d   = latest
  while d
    if ^d // Skip NONAME definitions
      if (typemask & ^_ffa_(d)) == type
        tab = tab + 1 + ^d
        if tab > width
          putln;
          tab = ^d
        else
          puts(" ")
        fin
        puts(d)
        if conio:keypressed(); conio:getkey(); conio:getkey(); fin
      fin
    fin
    d = *_lfa_(d)
  loop
end
def _words_#0
  putln
  typelist("Compile only: ", componly_flag, componly_flag)
  putln; putln
  typelist("Interpret only: ", interponly_flag, interponly_flag)
  putln; putln
  typelist("Both: ", componly_flag | interponly_flag, 0)
end
//
// Quit
//
def _quit_#0
  warmstart
  throw(@exitforth, FALSE)
end
//
// Abort
//
def _abort_(a)#0
  if a
    puts("Abort\n")
    _quit_
  fin
end
def _doabortstr_(a,b)#0
  if a
    puts("Abort: "); puts(b); putln
    _quit_
  fin
end
def _abortstr_#0
  word str
  byte len

  _str_
  if state & comp_flag
    _compword_(@d_doabortstr)
  else
    (@_doabortstr_)()#0
  fin
end
//
// Restart FORTH
//
def _restart_#0
  coldstart
  throw(@exitforth, FALSE)
end
//
// Leave FORTH
//
def _bye_#0
  throw(@exitforth, TRUE)
end
//
// Start FORTH
//
puts("PLEIADES FORTH v2.20\n")
if cmdsys:sysver < $0220
  puts("PLASMA >= 2.20 required\n")
  return
fin
//
// Compile ITC version of inline words ( speeds it up a smidge )
//
vmvect = *(@divmod + 1)  // Hack - get VM entry vector from divmod
latest = @d_words
while latest
  if *_cfa_(latest) == 0
    *_cfa_(latest) = heapmark
    _dictaddb_(JSR); _dictaddw_(vmvect)
    if ^_ffa_(latest) & inline_flag
      _dictaddb_(^_pfa_(latest))
    elsif ^_ffa_(latest) & inlinew_flag
      _dictaddw_(*_pfa_(latest))
    else
      puts(latest); puts(": Invalid dictionary\n")
      return -1
    fin
    _dictaddb_($5C) // RET
  fin
  latest = *_lfa_(latest)
loop
keyinbuf = heapalloc(INBUF_SIZE + 1)
fileio:iobufalloc(4) // Allocate a bunch of file buffers
strbuf = heapalloc(256)
inbuf  = heapalloc(SRCREFS * INBUF_SIZE)
startheap = heapmark
coldstart
//
// Check for command line argument
//
inptr = argNext(argFirst)
while ^inptr and ^(inptr + 1) == '-'
  when toupper(^(inptr + 2))
    is 'T' // Trace flag
      _tron_
    is 'D' // Debug flag (indirect threaded code)
      _itc_
      break
    otherwise
      puts("Usage: +PLFORTH [-T] [-D] [SCRIPT NAME]\n")
      return 0
  wend
  inptr = argNext(inptr)
loop
//
// Main start and restart entry
//
if not except(@exitforth)
  if ^inptr; inptr++; _srcstr_; fin
  _interpret_
fin
done
