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