6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2026-03-14 16:16:40 +00:00
Code Issues Projects Releases Wiki Activity
Files
e2ea8af61641038ec8a4c4476e4dc100fb9ce2e2
PLASMA/src/toolsrc/plforth.pla

1953 lines
45 KiB
Plaintext
Raw Blame History

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
Reference in New Issue View Git Blame Copy Permalink