mirror of
https://github.com/dschmenk/PLASMA.git
synced 2024-06-11 23:29:29 +00:00
751799352c
Have FORTH trya nd reserve space for temp string and PAD away from potential JIT interference
1997 lines
40 KiB
Plaintext
1997 lines
40 KiB
Plaintext
include "inc/cmdsys.plh"
|
|
include "inc/args.plh"
|
|
include "inc/fileio.plh"
|
|
include "inc/conio.plh"
|
|
include "inc/longjmp.plh"
|
|
//
|
|
// Internal variables
|
|
//
|
|
const JSR = $20 // 6502 JSR opcode needed for VM entry
|
|
const SRCREFS = 2
|
|
const INBUF_SIZE = 128
|
|
word vlist, infunc, inptr, IIP, W
|
|
word vmvect, startheap, arg
|
|
byte srclevel = 0
|
|
//
|
|
// Internal buffers
|
|
//
|
|
word strbuf, padbuf
|
|
res[SRCREFS * INBUF_SIZE] inbuf
|
|
res[t_except] exitforth
|
|
//
|
|
// Input references, pointers, and saved values
|
|
//
|
|
word keyinbuf = @inbuf // Point somewhere benign for starters (updated in keyin)
|
|
word inbufptr
|
|
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_itc_flag
|
|
byte state = 0
|
|
byte savestate = 0
|
|
word brkentry = 0
|
|
word brkcfa = 0
|
|
byte brk = 0
|
|
byte _get_estack = $8A // TXA
|
|
byte = $49, $FF // EOR #$FF
|
|
byte = $38 // SEC
|
|
byte = $69, $10 // ADC #$10
|
|
byte = $C9, $11 // CMP #$11
|
|
byte = $90, $02 // BCC +2
|
|
byte = $A2, $10 // LDX #ESTKSZ/2
|
|
byte = $CA // DEX
|
|
byte = $95 // STA
|
|
byte _estkl = $D0 // ESTKL,X
|
|
byte = $A9, $00 // LDA #$00
|
|
byte = $95 // STA
|
|
byte _estkh = $C0 // ESTKH,X
|
|
byte = $60 // RTS
|
|
byte _reset_estack = $A2, $10 // LDX #ESTKSZ/2
|
|
byte = $60 // RTS
|
|
//
|
|
// 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, _dashdup_(a)#1, _over_(a,b)#3, _rot_(a,b,c)#3
|
|
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, _leave_#0, _j_#1
|
|
predef _create_#0, _itcdoes_(a)#0, _does_#0, _compoff_#0, _compon_#0, _state_#1
|
|
predef _compile_#0, _forcecomp_#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
|
|
predef _cmove_(a,b,c)#0, _move_(a,b,c)#0, _fill_(a,b,c)#0, _plasma_(a)#0
|
|
predef _var_(a)#0, _const_(a)#0, _lit_#1, _slit_#1, _find_(a)#2
|
|
predef _tick_#0, _forget_#0, _terminal_#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, _accept_(a,b)#1, _type_(a,b)#0
|
|
predef _vlist_#0, _tron_#0, _troff_#0, _stepon_#0, _stepoff_#0
|
|
predef _itc_#0, _pbc_#0, _comment_#0, _src_(a)#0, _srcstr_#0, _endsrc_(a)#0
|
|
predef _brk_#0, _brkon_#0, _brkoff_#0, _word_(a)#1, _count_(a)#2
|
|
predef _space_#0, _spaces_(a)#0, _show_#0, _showstack_#0, _showrstack_#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
|
|
// DROP
|
|
char d_drop = "DROP"
|
|
byte = inline_flag | showcr_flag
|
|
word = 0, 0, 0, $30
|
|
// SWAP
|
|
char d_swap = "SWAP"
|
|
byte = 0
|
|
word = @d_drop, 0, @_swap_
|
|
// DUP
|
|
char d_dup = "DUP"
|
|
byte = inline_flag
|
|
word = @d_swap, 0, 0, $34
|
|
// -DUP
|
|
char d_dashdup = "-DUP"
|
|
byte = 0
|
|
word = @d_dup, 0, @_dashdup_
|
|
// OVER
|
|
word d_over = "OVER"
|
|
byte = 0
|
|
word = @d_dashdup, 0, @_over_
|
|
// ROT
|
|
word d_rot = "ROT"
|
|
byte = 0
|
|
word = @d_over, 0, @_rot_
|
|
// ADD
|
|
char d_add = "+"
|
|
byte = inline_flag
|
|
word = @d_rot, 0, 0, $82
|
|
// ONE PLUS
|
|
char d_inc = "1+"
|
|
byte = inline_flag
|
|
word = @d_add, 0, 0, $8C
|
|
// TWO PLUS
|
|
char d_inc2 = "2+"
|
|
byte = inlinew_flag
|
|
word = @d_inc, 0, 0, $8C8C
|
|
// ONE MINUS
|
|
char d_dec = "1-"
|
|
byte = inline_flag
|
|
word = @d_inc2, 0, 0, $8E
|
|
// TWO MINUS
|
|
char d_dec2 = "2-"
|
|
byte = inlinew_flag
|
|
word = @d_dec, 0, 0, $8E8E
|
|
// SUB
|
|
char d_sub = "-"
|
|
byte = inline_flag
|
|
word = @d_dec2, 0, 0, $84
|
|
// MUL
|
|
char d_mul = "*"
|
|
byte = inline_flag
|
|
word = @d_sub, 0, 0, $86
|
|
// DIV
|
|
char d_div = "/"
|
|
byte = inline_flag
|
|
word = @d_mul, 0, 0, $88
|
|
// DIVMOD
|
|
char d_divmod = "/MOD"
|
|
byte = inline_flag
|
|
word = @d_div, 0, 0, $36
|
|
// MOD
|
|
char d_mod = "MOD"
|
|
byte = inline_flag
|
|
word = @d_divmod, 0, 0, $8A
|
|
// NEG
|
|
char d_neg = "NEGATE"
|
|
byte = inline_flag
|
|
word = @d_mod, 0, 0, $90
|
|
// AND
|
|
char d_and = "AND"
|
|
byte = inline_flag
|
|
word = @d_neg, 0, 0, $94
|
|
// OR
|
|
char d_or = "OR"
|
|
byte = inline_flag
|
|
word = @d_and, 0, 0, $96
|
|
// XOR
|
|
char d_xor = "XOR"
|
|
byte = inline_flag
|
|
word = @d_or, 0, 0, $98
|
|
// COMPLEMENT
|
|
char d_complement = "COMPLEMENT"
|
|
byte = inline_flag
|
|
word = @d_xor, 0, 0, $92
|
|
// NOT
|
|
char d_not = "NOT"
|
|
byte = inline_flag
|
|
word = @d_complement, 0, 0, $80
|
|
// LEFT SHIFT
|
|
char d_lshift = "LSHIFT"
|
|
byte = inline_flag
|
|
word = @d_not, 0, 0, $9A
|
|
// RIGHT SHIFT
|
|
char d_rshift = "RSHIFT"
|
|
byte = inline_flag
|
|
word = @d_lshift, 0, 0, $9C
|
|
// EQUALS
|
|
char d_eq = "="
|
|
byte = inline_flag
|
|
word = @d_rshift, 0, 0, $40
|
|
// GREATER THAN
|
|
char d_gt = ">"
|
|
byte = inline_flag
|
|
word = @d_eq, 0, 0, $44
|
|
// LESS THAN
|
|
char d_lt = "<"
|
|
byte = inline_flag
|
|
word = @d_gt, 0, 0, $46
|
|
// UNSIGNED GREATER THAN
|
|
char d_ugt = "U>"
|
|
byte = 0
|
|
word = @d_lt, 0, @isugt
|
|
// UNSIGNED LESS THAN
|
|
char d_ult = "U<"
|
|
byte = 0
|
|
word = @d_ugt, 0, @isult
|
|
// LESS THAN ZERO
|
|
char d_0lt = "0<"
|
|
byte = inlinew_flag
|
|
word = @d_ult, 0, 0, $4600 // ZERO ISLT
|
|
// EQUALS ZERO
|
|
char d_0eq = "0="
|
|
byte = inlinew_flag
|
|
word = @d_0lt, 0, 0, $4000 // ZERO ISEQ
|
|
// ABS
|
|
char d_abs = "ABS"
|
|
byte = 0
|
|
word = @d_0eq, 0, @_abs_
|
|
// MIN
|
|
char d_min = "MIN"
|
|
byte = 0
|
|
word = @d_abs, 0, @_min_
|
|
// MAX
|
|
char d_max = "MAX"
|
|
byte = 0
|
|
word = @d_min, 0, @_max_
|
|
// CHAR PUT
|
|
char d_cset = "C!"
|
|
byte = inline_flag | showcr_flag
|
|
word = @d_max, 0, 0, $70
|
|
// WORD PUT
|
|
char d_wset = "!"
|
|
byte = inline_flag | showcr_flag
|
|
word = @d_cset, 0, 0, $72
|
|
// WORD PLUS PUT
|
|
char d_wplusset = "+!"
|
|
byte = showcr_flag
|
|
word = @d_wset, 0, @_wplusset_
|
|
// CHAR GET
|
|
char d_cget = "C@"
|
|
byte = inline_flag
|
|
word = @d_wplusset, 0, 0, $60
|
|
// WORD SET
|
|
char d_wget = "@"
|
|
byte = inline_flag
|
|
word = @d_cget, 0, 0, $62
|
|
// EXECUTE
|
|
char d_execute = "EXECUTE"
|
|
byte = showcr_flag
|
|
word = @d_wget, 0, @_execword_
|
|
// TO RSTACK
|
|
char d_torstk = ">R"
|
|
byte = showcr_flag
|
|
word = @d_execute, 0, @_tors_
|
|
// FROM RSTACK
|
|
char d_fromrstk = "R>"
|
|
byte = 0
|
|
word = @d_torstk, 0, @_fromrs_
|
|
// TOP OF RSTACK
|
|
char d_toprstk = "R@"
|
|
byte = 0
|
|
word = @d_fromrstk, 0, @_toprs_
|
|
// PLASMA SYMBOL LOOKUP
|
|
char d_lookup = "LOOKUP"
|
|
byte = 0
|
|
word = @d_toprstk, 0, @_lookup_
|
|
// PLASMA LINKEAGE
|
|
char d_plasma = "PLASMA"
|
|
byte = interponly_flag
|
|
word = @d_lookup, 0, @_plasma_
|
|
// VARIABLE
|
|
char d_var = "VARIABLE"
|
|
byte = interponly_flag
|
|
word = @d_plasma, 0, @_var_
|
|
// CONSTANT
|
|
char d_const = "CONSTANT"
|
|
byte = interponly_flag
|
|
word = @d_var, 0, @_const_
|
|
// CMOVE
|
|
char d_cmove = "CMOVE"
|
|
byte = showcr_flag
|
|
word = @d_const, 0, @_cmove_
|
|
// MOVE
|
|
char d_move = "MOVE"
|
|
byte = showcr_flag
|
|
word = @d_cmove, 0, @_move_
|
|
// FILL
|
|
char d_fill = "FILL"
|
|
byte = showcr_flag
|
|
word = @d_cmove, 0, @_fill_
|
|
// HERE
|
|
char d_here = "HERE"
|
|
byte = 0
|
|
word = @d_fill, 0, @heapmark
|
|
// PAD
|
|
char d_pad = "PAD"
|
|
byte = 0
|
|
word = @d_here, 0, @_pad_
|
|
// ALLOT
|
|
char d_allot = "ALLOT"
|
|
byte = showcr_flag
|
|
word = @d_pad, 0, @_allot_
|
|
// BRANCH ( not in vocabulary )
|
|
char d_branch = "(BRANCH)"
|
|
byte = param_flag | inline_flag | showcr_flag
|
|
word = 0, 0, @_branch_, $C4
|
|
// BRANCH IF 0 ( not in vocabulary )
|
|
char d_0branch = "(0BRANCH)"
|
|
byte = param_flag | inline_flag | showcr_flag
|
|
word = 0, 0, @_0branch_, $C2
|
|
// IF
|
|
char d_if = "IF"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_allot, 0, @_if_
|
|
// ELSE
|
|
char d_else = "ELSE"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_if, 0, @_else_
|
|
// THEN
|
|
char d_then = "THEN"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_else, 0, @_then_
|
|
// CASE
|
|
char d_case = "CASE"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_then, 0, @_case_
|
|
// OF
|
|
char d_of = "OF"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_case, 0, @_of_
|
|
// ENDOF
|
|
char d_endof = "ENDOF"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_of, 0, @_endof_
|
|
// ENDCASE
|
|
char d_endcase = "ENDCASE"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_endof, 0, @_endcase_
|
|
// COMPILED DO ( not in vocabulary )
|
|
char d_dodo = "(DO)"
|
|
byte = showcr_flag
|
|
word = 0, 0, @_dodo_
|
|
// DO
|
|
char d_do = "DO"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_endcase, 0, @_do_
|
|
// LEAVE
|
|
char d_leave = "LEAVE"
|
|
byte = componly_flag | showcr_flag
|
|
word = @d_do, 0, @_leave_
|
|
// COMPILED LOOP ( not in vocabulary )
|
|
char d_doloop = "(DOLOOP)"
|
|
byte = param_flag | showcr_flag
|
|
word = 0, 0, @_doloop_
|
|
// LOOP
|
|
char d_loop = "LOOP"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_leave, 0, @_loop_
|
|
// COMPILED LOOP+ ( not in vocabulary )
|
|
char d_doplusloop = "(+DOLOOP)"
|
|
byte = param_flag | showcr_flag
|
|
word = 0, 0, @_doplusloop_
|
|
// LOOP
|
|
char d_plusloop = "+LOOP"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_loop, 0, @_plusloop_
|
|
// I
|
|
char d_i = "I"
|
|
byte = componly_flag
|
|
word = @d_plusloop, 0, @_toprs_
|
|
// J
|
|
char d_j = "J"
|
|
byte = componly_flag
|
|
word = @d_i, 0, @_j_
|
|
// BEGIN
|
|
char d_begin = "BEGIN"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_j, 0, @_begin_
|
|
// AGAIN
|
|
char d_again = "AGAIN"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_begin, 0, @_again_
|
|
// UNTIL
|
|
char d_until = "UNTIL"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_again, 0, @_until_
|
|
// WHILE
|
|
char d_while = "WHILE"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_until, 0, @_while_
|
|
// REPEAT
|
|
char d_repeat = "REPEAT"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_while, 0, @_repeat_
|
|
// FORGET
|
|
char d_forget = "FORGET"
|
|
byte = interponly_flag
|
|
word = @d_repeat, 0, @_forget_
|
|
// CREATE
|
|
char d_create = "CREATE"
|
|
byte = showcr_flag
|
|
word = @d_forget, 0, @_create_
|
|
// RECREATE/DOES COMPILE TIME ( not in vocabulary )
|
|
char d_createdoes = "(CREATEDOES)"
|
|
byte = showcr_flag
|
|
word = 0, 0, @_itcdoes_
|
|
// DOES
|
|
char d_does = "DOES>"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_create, 0, @_does_
|
|
// COMMA
|
|
char d_comma = ","
|
|
byte = showcr_flag
|
|
word = @d_does, 0, @_dictaddw_
|
|
// COMMA
|
|
char d_commab = "C,"
|
|
byte = showcr_flag
|
|
word = @d_comma, 0, @_dictaddb_
|
|
// STATE
|
|
char d_state = "STATE"
|
|
byte = 0
|
|
word = @d_commab, 0, @_state_
|
|
// COLON
|
|
char d_colon = ":"
|
|
byte = interponly_flag
|
|
word = @d_state, 0, @_colon_
|
|
// COMP OFF
|
|
char d_compoff = "["
|
|
byte = imm_flag | componly_flag
|
|
word = @d_colon, 0, @_compoff_
|
|
// COMP ON
|
|
char d_compon = "]"
|
|
byte = interponly_flag
|
|
word = @d_compoff, 0, @_compon_
|
|
// COMPILE WORD ON STACK
|
|
char d_compword = "(COMPILE)"
|
|
byte = componly_flag
|
|
word = @d_compon, 0, @_compword_
|
|
// COMPILE NEXT WORD
|
|
char d_compile = "COMPILE"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_compword, 0, @_compile_
|
|
// FORCE COMPILE NEXT WORD
|
|
char d_forcecomp = "[COMPILE]"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_compile, 0, @_forcecomp_
|
|
// COMPILE ONLY
|
|
char d_componly = "COMPONLY"
|
|
byte = imm_flag
|
|
word = @d_forcecomp, 0, @_componly_
|
|
// INTERPRET ONLY
|
|
char d_interponly = "INTERPONLY"
|
|
byte = imm_flag
|
|
word = @d_componly, 0, @_interponly_
|
|
// IMMEDIATE
|
|
char d_immediate = "IMMEDIATE"
|
|
byte = imm_flag
|
|
word = @d_interponly, 0, @_immediate_
|
|
// EXIT
|
|
char d_exit = "EXIT"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_immediate, 0, @_exit_
|
|
// SEMI
|
|
char d_semi = ";"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_exit, 0, @_semi_
|
|
// COUNT
|
|
char d_count = "COUNT"
|
|
byte = 0
|
|
word = @d_semi, 0, @_count_
|
|
// FIND
|
|
char d_find = "FIND"
|
|
byte = 0
|
|
word = @d_count, 0, @_find_
|
|
// TICK
|
|
char d_tick = "'"
|
|
byte = imm_flag
|
|
word = @d_find, 0, @_tick_
|
|
// INLINE LITERAL NUMBER ( not in vocabulary )
|
|
char d_lit = "LIT"
|
|
byte = param_flag
|
|
word = 0, 0, @_lit_
|
|
// COMPILED LITERAL VALUE FROM STACK
|
|
char d_literal = "LITERAL"
|
|
byte = imm_flag | componly_flag
|
|
word = @d_tick, 0, @_compliteral_
|
|
// ?TERMINAL
|
|
char d_terminal = "?TERMINAL"
|
|
byte = 0
|
|
word = @d_literal, 0, @_terminal_
|
|
// KEY
|
|
char d_key = "KEY"
|
|
byte = 0
|
|
word = @d_terminal, 0, @_key_
|
|
// ACCEPT
|
|
char d_accept = "ACCEPT"
|
|
byte = 0
|
|
word = @d_key, 0, @_accept_
|
|
// WORD
|
|
char d_word = "WORD"
|
|
byte = 0
|
|
word = @d_accept, 0, @_word_
|
|
// _isnum_
|
|
char d__isnum_ = "?NUM"
|
|
byte = 0
|
|
word = @d_word, 0, @_isnum_
|
|
// -TRAILING
|
|
char d_trailing = "-TRAILING"
|
|
byte = 0
|
|
word = @d__isnum_, 0, @_trailing_
|
|
// PRINT @TOS
|
|
char d_prat = "?"
|
|
byte = 0
|
|
word = @d_trailing, 0, @_prat_
|
|
// PRINT TOS
|
|
char d_prtos = "."
|
|
byte = 0
|
|
word = @d_prat, 0, @_prval_
|
|
// PRINT TOS HEX
|
|
char d_prtoshex = "$."
|
|
byte = 0
|
|
word = @d_prtos, 0, @_prhex_
|
|
// PRINT TOS HEX BYTE
|
|
char d_prtosbyte = "C$."
|
|
byte = 0
|
|
word = @d_prtoshex, 0, @_prbyte_
|
|
// EMIT
|
|
char d_emit = "EMIT"
|
|
byte = 0
|
|
word = @d_prtosbyte, 0, @putc
|
|
// CR
|
|
char d_cr = "CR"
|
|
byte = showcr_flag
|
|
word = @d_emit, 0, @putln
|
|
// SPACE
|
|
char d_space = "SPACE"
|
|
byte = 0
|
|
word = @d_cr, 0, @_space_
|
|
// SPACES
|
|
char d_spaces = "SPACES"
|
|
byte = 0
|
|
word = @d_space, 0, @_spaces_
|
|
// TYPE
|
|
char d_type = "TYPE"
|
|
byte = 0
|
|
word = @d_spaces, 0, @_type_
|
|
// BLANK
|
|
char d_blank = "BL"
|
|
byte = imm_flag
|
|
word = @d_type, 0, @_blank_
|
|
// CHAR
|
|
char d_char = "CHAR"
|
|
byte = imm_flag
|
|
word = @d_blank, 0, @_char_
|
|
// STRING
|
|
char d_str = "\""
|
|
byte = imm_flag
|
|
word = @d_char, 0, @_str_
|
|
// LITERAL STRING ( not in vocabulary )
|
|
char d_slit = "SLIT"
|
|
byte = param_flag | inline_flag
|
|
word = 0, 0, @_slit_, $2E
|
|
// PRINT STRING FROM STACK
|
|
char d_doprstr = "(.\")"
|
|
byte = 0
|
|
word = @d_str, 0, @puts
|
|
// PRINT STRING
|
|
char d_prstr = ".\""
|
|
byte = imm_flag
|
|
word = @d_doprstr, 0, @_prstr_
|
|
// PRINT PAREN STRING
|
|
char d_prpstr = ".("
|
|
byte = imm_flag
|
|
word = @d_prstr, 0, @_prpstr_
|
|
// READ SOURCE FILE FROM STACK
|
|
char d_src = "SRC"
|
|
byte = showcr_flag
|
|
word = @d_prpstr, 0, @_src_
|
|
// READ SOURCE FILE FROM INPUT
|
|
char d_srcstr = "SRC\""
|
|
byte = imm_flag
|
|
word = @d_src, 0, @_srcstr_
|
|
// END SOURCE FILE
|
|
char d_endsrc = "ENDSRC"
|
|
byte = showcr_flag
|
|
word = @d_srcstr, 0, @_endsrc_
|
|
// CONTINUE AFTER BRK
|
|
char d_cont = "CONT"
|
|
byte = interponly_flag
|
|
word = @d_endsrc, 0, @_cont_
|
|
// QUIT
|
|
char d_quit = "QUIT"
|
|
byte = showcr_flag
|
|
word = @d_cont, 0, @_quit_
|
|
// ABORT IF <> 0
|
|
char d_abort = "ABORT"
|
|
byte = showcr_flag
|
|
word = @d_quit, 0, @_abort_
|
|
// DOABORTSTR
|
|
char d_doabortstr = "(ABORT\")"
|
|
byte = showcr_flag
|
|
word = @d_abort, 0, @_doabortstr_
|
|
// ABORTSTR
|
|
char d_abortstr = "ABORT\""
|
|
byte = imm_flag
|
|
word = @d_doabortstr, 0, @_abortstr_
|
|
// COLD exitforth
|
|
char d_exitforth = "COLD"
|
|
byte = showcr_flag
|
|
word = @d_abortstr, 0, @_restart_
|
|
// COMMENT
|
|
char d_comment = "("
|
|
byte = imm_flag
|
|
word = @d_exitforth, 0, @_comment_
|
|
//
|
|
// PLFORTH custom words
|
|
//
|
|
// BYE
|
|
char d_bye = "BYE"
|
|
byte = 0
|
|
word = @d_comment, 0, @_bye_
|
|
// SHOW DEFINITION
|
|
char d_show = "SHOW"
|
|
byte = interponly_flag
|
|
word = @d_bye, 0, @_show_
|
|
// SHOW STACK
|
|
char d_showstack = "SHOWSTACK"
|
|
byte = showcr_flag
|
|
word = @d_show, 0, @_showstack_
|
|
// SHOW RSTACK
|
|
char d_showrstack = "SHOWRSTACK"
|
|
byte = showcr_flag
|
|
word = @d_showstack, 0, @_showrstack_
|
|
// TRACE ON
|
|
char d_tron = "TRON"
|
|
byte = showcr_flag
|
|
word = @d_showrstack, 0, @_tron_
|
|
// TRACE OFF
|
|
char d_troff = "TROFF"
|
|
byte = showcr_flag
|
|
word = @d_tron, 0, @_troff_
|
|
// SINGLE STEP ON
|
|
char d_stepon = "STEPON"
|
|
byte = showcr_flag
|
|
word = @d_troff, 0, @_stepon_
|
|
// SINGLE STEP OFF
|
|
char d_stepoff = "STEPOFF"
|
|
byte = showcr_flag
|
|
word = @d_stepon, 0, @_stepoff_
|
|
// BREAK OUT
|
|
char d_brk = "BRK"
|
|
byte = showcr_flag
|
|
word = @d_stepoff, 0, @_brk_
|
|
// BREAK ON
|
|
char d_brkon = "BRKON"
|
|
byte = interponly_flag
|
|
word = @d_brk, 0, @_brkon_
|
|
// BREAK OFF
|
|
char d_brkoff = "BRKOFF"
|
|
byte = interponly_flag
|
|
word = @d_brkon, 0, @_brkoff_
|
|
// COMPILE USING ITC
|
|
char d_itc = "ITC"
|
|
byte = interponly_flag
|
|
word = @d_brkoff, 0, @_itc_
|
|
// COMPILE USING PLASMA BYTECODES
|
|
char d_pbc = "PBC"
|
|
byte = interponly_flag
|
|
word = @d_itc, 0, @_pbc_
|
|
//
|
|
// Start of vocabulary
|
|
//
|
|
// LIST VOCAB
|
|
char d_vlist = "VLIST"
|
|
byte = showcr_flag
|
|
word = @d_pbc, 0, @_vlist_
|
|
//
|
|
// Helper routines
|
|
//
|
|
predef _interpret_#0
|
|
def push(a)#1 // Stack hack - call as (@push)(a)#0 to leave a on eval stack
|
|
return a
|
|
end
|
|
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")
|
|
inptr = gets(state & comp_flag ?? ']'|$80 :: '>'|$80)
|
|
keyinbuf = inptr // Save if needed
|
|
until ^inptr
|
|
^(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 hashname(chars, len)#1
|
|
return (len ^ ((^chars << 1) ^ ^(chars + len / 2) << 2)) & HASH_MASK
|
|
end
|
|
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 i, hash
|
|
|
|
for i = 0 to HASH_MASK
|
|
hashtbl[i] = 0
|
|
next
|
|
dentry = vlist
|
|
while dentry
|
|
hash = hashname(dentry + 1, ^dentry)
|
|
*_hfa_(dentry) = hashtbl[hash])
|
|
hashtbl[hash] = dentry
|
|
dentry = *(dentry + ^dentry + 2)
|
|
loop
|
|
end
|
|
//
|
|
// Warm start
|
|
//
|
|
def warmstart#0
|
|
(@_reset_estack)()#0
|
|
brk = 0
|
|
brkcfa = 0
|
|
RSP = RSTK_SIZE
|
|
if state & comp_flag // Undo compilation state
|
|
heaprelease(vlist)
|
|
vlist = *_lfa_(vlist)
|
|
fin
|
|
state = 0
|
|
while !endsrc; loop
|
|
infunc = @keyin
|
|
inptr = keyinbuf
|
|
^inptr = 0
|
|
end
|
|
//
|
|
// Cold start
|
|
//
|
|
def coldstart#0
|
|
warmstart
|
|
vlist = @d_vlist
|
|
heaprelease(startheap)
|
|
buildhashtbl
|
|
end
|
|
//
|
|
// Find match in dictionary
|
|
//
|
|
def find(matchchars, matchlen)#1
|
|
word dentry
|
|
byte i
|
|
|
|
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 = *(dentry + ^dentry + 4)
|
|
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 == '$'
|
|
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
|
|
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("( "); _showstack_; puts(") "); puts(dentry); putc(' ')
|
|
end
|
|
def brkhandle(dentry)#0
|
|
word brk_infn, brk_inptr, brk_iip
|
|
byte brk_state
|
|
|
|
showtrace(dentry)
|
|
brk_iip = IIP
|
|
brk_infn = infunc
|
|
brk_inptr = inptr
|
|
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
|
|
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_estack)()#1 > 16
|
|
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)
|
|
elsif state & 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 ^_ffa_(dentry) & imm_flag or not (state & comp_flag)
|
|
if ^_ffa_(dentry) & componly_flag and not (state & comp_flag)
|
|
puts(dentry)
|
|
puts(" : Compile only word\n")
|
|
_quit_
|
|
fin
|
|
_execword_(dentry)
|
|
else
|
|
_compword_(dentry)
|
|
fin
|
|
else
|
|
value, valid = _isnum_(inchars, inlen)
|
|
if not valid
|
|
inchars--
|
|
^inchars = inlen
|
|
puts(inchars)
|
|
puts(" ? No match\n")
|
|
warmstart
|
|
else
|
|
if state & comp_flag
|
|
_compliteral_(value)
|
|
else
|
|
(@push)(value)#0
|
|
fin
|
|
fin
|
|
fin
|
|
until state & exit_flag
|
|
state = state & ~exit_flag
|
|
end
|
|
//
|
|
// Intrinsics
|
|
//
|
|
def _swap_(a,b)#2
|
|
return b,a
|
|
end
|
|
def _dashdup_(a)#1
|
|
if a; (@push)(a)#0; fin
|
|
return a
|
|
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 _ffa_(dentry)#1
|
|
return dentry + ^dentry + 1
|
|
end
|
|
def _lfa_(dentry)#1
|
|
return dentry + ^dentry + 2
|
|
end
|
|
def _hfa_(dentry)#1
|
|
return dentry + ^dentry + 4
|
|
end
|
|
def _cfa_(dentry)#1
|
|
return dentry + ^dentry + 6
|
|
end
|
|
def _pfa_(dentry)#1
|
|
return dentry + ^dentry + 8
|
|
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 padbuf
|
|
end
|
|
def _trailing_(a,b)#2
|
|
while b and ^(a + b - 1) == ' '
|
|
b--
|
|
loop
|
|
return a, b
|
|
end
|
|
def newdict#0
|
|
word bldptr, plist, namechars, namelen
|
|
|
|
namechars, namelen = nextword(' ')
|
|
plist = vlist
|
|
vlist = heapmark
|
|
^vlist = namelen
|
|
bldptr = vlist + 1
|
|
while namelen
|
|
^bldptr = ^namechars
|
|
bldptr++
|
|
namechars++
|
|
namelen--
|
|
loop
|
|
^bldptr = 0 // Flags
|
|
bldptr++
|
|
*bldptr = plist; // Link ptr
|
|
bldptr = bldptr + 2
|
|
*bldptr = 0; // Hash ptr
|
|
bldptr = bldptr + 2
|
|
*bldptr = bldptr + 2 // Point CFA to PFA
|
|
heapalloc(bldptr - vlist + 2)
|
|
end
|
|
def _plasma_(a)#0
|
|
newdict
|
|
^(_ffa_(vlist)) = showcr_flag
|
|
*(_cfa_(vlist)) = a // PLASMA code address
|
|
addhash(vlist)
|
|
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(vlist)
|
|
end
|
|
def _const_(a)#0
|
|
newdict
|
|
_dictaddb_(JSR); _dictaddw_(vmvect)
|
|
_dictaddb_($2C) // CONSTANT WORD
|
|
_dictaddw_(a)
|
|
_dictaddb_($5C) // RET
|
|
addhash(vlist)
|
|
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>
|
|
//
|
|
// 9 bytes after PFA, data follows...
|
|
//
|
|
end
|
|
def _state_#1
|
|
return state & comp_flag
|
|
end
|
|
def _dodoes_#0
|
|
(@push)(W + 11)#0 // Pointer to PFA storage
|
|
execwords(*(W + 2)) // Exec PFA ptr
|
|
end
|
|
def _itcdoes_(a)#0
|
|
//
|
|
// Overwrite CREATE as ITC words
|
|
//
|
|
^(_ffa_(vlist)) = ^(_ffa_(vlist)) | itc_flag
|
|
*(_cfa_(vlist)) = @_dodoes_
|
|
*(_pfa_(vlist)) = a // Fill in DOES code address
|
|
addhash(vlist)
|
|
end
|
|
def _pbcdoes_(a)#0
|
|
//
|
|
// Rewrite the end of CREATE
|
|
//
|
|
^(_pfa_(vlist) + 6) = $C4 // JUMP DOES> directly
|
|
*(_pfa_(vlist) + 7) = a
|
|
addhash(vlist)
|
|
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 _docolon_#0
|
|
execwords(W + 2) // Exec PFA
|
|
end
|
|
def _colon_#0
|
|
newdict
|
|
state = state | comp_mode
|
|
if state & comp_itc_flag
|
|
^(_ffa_(vlist)) = itc_flag | showcr_flag
|
|
*(_cfa_(vlist)) = @_docolon_
|
|
else // comp_pbc_flag
|
|
^(_ffa_(vlist)) = showcr_flag
|
|
_dictaddb_(JSR); _dictaddw_(vmvect)
|
|
fin
|
|
if state & trace_flag
|
|
puts(vlist); putc(' ')
|
|
fin
|
|
end
|
|
def _exit_#0
|
|
if state & comp_itc_flag
|
|
_dictaddw_(0)
|
|
elsif state & comp_pbc_flag
|
|
_dictaddb_($5C) // RET
|
|
else
|
|
puts("; Not compiling\n")
|
|
_quit_
|
|
fin
|
|
end
|
|
def _semi_#0
|
|
_exit_
|
|
if state & comp_itc_flag // Add double zero at end of definition for SHOW
|
|
_dictaddw_(0)
|
|
fin
|
|
addhash(vlist)
|
|
state = state & ~comp_flag
|
|
end
|
|
def _compile_#0
|
|
word dentry
|
|
|
|
dentry = find(nextword(' '))
|
|
if dentry
|
|
if ^_ffa_(dentry) & imm_flag
|
|
_compword_(dentry)
|
|
else
|
|
_compliteral_(dentry)
|
|
_compword_(@d_compword)
|
|
fin
|
|
else
|
|
puts("No match\n")
|
|
_quit_
|
|
fin
|
|
end
|
|
def _forcecomp_#0
|
|
word dentry
|
|
|
|
dentry = find(nextword(' '))
|
|
if dentry
|
|
_compliteral_(dentry)
|
|
_compword_(@d_compword)
|
|
else
|
|
puts("No match\n")
|
|
_quit_
|
|
fin
|
|
end
|
|
def _compoff_#0
|
|
savestate = state & comp_flag
|
|
state = state & ~comp_flag
|
|
end
|
|
def _compon_#0
|
|
state = state | savestate
|
|
savestate = 0
|
|
if not (state & comp_flag)
|
|
puts("] Not compiling\n")
|
|
_quit_
|
|
fin
|
|
end
|
|
def _componly_#0
|
|
^_ffa_(vlist) = ^_ffa_(vlist) | componly_flag
|
|
end
|
|
def _interponly_#0
|
|
^_ffa_(vlist) = ^_ffa_(vlist) | interponly_flag
|
|
end
|
|
def _immediate_#0
|
|
^_ffa_(vlist) = ^_ffa_(vlist) | imm_flag
|
|
end
|
|
def _branch_#0
|
|
IIP = *IIP
|
|
end
|
|
def _0branch_(a)#0
|
|
if a
|
|
IIP = IIP + 2
|
|
else
|
|
IIP = *IIP
|
|
fin
|
|
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 _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)#0
|
|
fin
|
|
end
|
|
def _forget_#0
|
|
word dentry
|
|
|
|
dentry = find(nextword(' '))
|
|
if dentry
|
|
if isult(dentry, startheap)
|
|
vlist = @d_vlist
|
|
dentry = startheap
|
|
else
|
|
vlist = *_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 _terminal_#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 _prat_(a)#0
|
|
puti(*a); putc(' ')
|
|
end
|
|
def _blank_#0
|
|
if state & comp_flag
|
|
_compliteral_(32)
|
|
else
|
|
(@push)(32)#0
|
|
fin
|
|
end
|
|
def _char_#0
|
|
word str
|
|
byte len
|
|
|
|
str, len = nextword(' ')
|
|
if state & comp_flag
|
|
_compliteral_(^str)
|
|
else
|
|
(@push)(^str)#0
|
|
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)#0
|
|
memcpy(strbuf, str, len) // Copy to HERE
|
|
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_(a)#0
|
|
if a
|
|
endsrc
|
|
fin
|
|
end
|
|
def _show_#0
|
|
word dentry, pfa, w
|
|
|
|
dentry = find(nextword(' '))
|
|
if dentry and ^_ffa_(dentry) & itc_flag // Only show ITC words
|
|
if *_cfa_(dentry) == @_docolon_
|
|
pfa = _pfa_(dentry)
|
|
else // @d_dodoes
|
|
pfa = *_pfa_(dentry)
|
|
fin
|
|
w = *pfa
|
|
while w
|
|
puts(" ")
|
|
if ^_ffa_(w) & param_flag
|
|
pfa = pfa + 2
|
|
fin
|
|
if w == @d_slit
|
|
putc('"')
|
|
puts(pfa)
|
|
putc('"')
|
|
pfa = pfa + ^pfa - 1
|
|
elsif w == @d_lit
|
|
puti(*pfa)
|
|
else
|
|
puts(w)
|
|
fin
|
|
if ^_ffa_(w) & showcr_flag; putln; fin
|
|
pfa = pfa + 2
|
|
w = *pfa
|
|
if !w
|
|
pfa = pfa + 2
|
|
w = *pfa
|
|
if !*w; puts(" EXIT\n"); fin
|
|
fin
|
|
if conio:keypressed()
|
|
conio:getkey(); conio:getkey()
|
|
fin
|
|
loop
|
|
puts(" EXIT\n")
|
|
fin
|
|
end
|
|
def _showstack_#0
|
|
word val
|
|
byte depth
|
|
|
|
for depth = 1 to (@_get_estack)()#1
|
|
val = ^(_estkl + 16 - depth) | (^(_estkh + 16 - depth) << 8)
|
|
puti(val); putc(' ')
|
|
next
|
|
end
|
|
def _showrstack_#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
|
|
|
|
puts(typestr)
|
|
tab = ^typestr
|
|
d = vlist
|
|
while d
|
|
if (typemask & ^_ffa_(d)) == type
|
|
tab = tab + 1 + ^d
|
|
if tab > 39
|
|
putln;
|
|
tab = ^d
|
|
else
|
|
puts(" ")
|
|
fin
|
|
puts(d)
|
|
if conio:keypressed(); conio:getkey(); conio:getkey(); fin
|
|
fin
|
|
d = *_lfa_(d)
|
|
loop
|
|
end
|
|
def _vlist_#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("FORTH for PLASMA 2.1\n")
|
|
if cmdsys:sysver < $0201
|
|
puts("PLASMA >= 2.01 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
|
|
vlist = @d_vlist
|
|
while vlist
|
|
if *_cfa_(vlist) == 0
|
|
*_cfa_(vlist) = heapmark
|
|
_dictaddb_(JSR); _dictaddw_(vmvect)
|
|
if ^_ffa_(vlist) & inline_flag
|
|
_dictaddb_(^_pfa_(vlist))
|
|
elsif ^_ffa_(vlist) & inlinew_flag
|
|
_dictaddw_(*_pfa_(vlist))
|
|
else
|
|
puts(vlist); puts(": Invalid dictionary\n")
|
|
return -1
|
|
fin
|
|
_dictaddb_($5C) // RET
|
|
fin
|
|
vlist = *_lfa_(vlist)
|
|
loop
|
|
_estkl = ^(@syscall + 1) // Hack to fill in parameter stack locations
|
|
_estkh = ^(@syscall + 3)
|
|
fileio:iobufalloc(4) // Allocate a bunch of file buffers
|
|
strbuf = heapalloc(256)
|
|
padbuf = heapalloc(256)
|
|
startheap = heapmark
|
|
coldstart
|
|
//
|
|
// Check for command line argument
|
|
//
|
|
inptr = argNext(argFirst)
|
|
//
|
|
// Main start and restart entry
|
|
//
|
|
if not except(@exitforth)
|
|
if ^inptr; inptr++; _srcstr_; fin
|
|
_interpret_
|
|
fin
|
|
done
|