6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2024-06-01 03:41:34 +00:00
Code Issues Projects Releases Wiki Activity
d5c22b1ff0
PLASMA/src/toolsrc/plforth.pla

1958 lines
39 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"
//
// Internal variables
//
word vlist, infunc, inptr, IIP, W
word vmvect, startheap, arg
word keyinbuf = $1FF
const JSR = $20 // 6502 JSR opcode needed for VM entry
const SRCREFS = 2
const INBUF_SIZE = 128
byte srclevel = 0
word inbufptr
byte inref[SRCREFS]
word previnptr[SRCREFS]
//
// Internal buffers
//
res[SRCREFS * INBUF_SIZE] inbuf
res[t_except] exitforth
//
// 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
predef _compile_#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
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_
// COLON
char d_colon = ":"
byte = interponly_flag
word = @d_commab, 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 NEXT WORD
char d_compile = "[COMPILE]"
byte = imm_flag | componly_flag
word = @d_compon, 0, @_compile_
// COMPILE ONLY
char d_componly = "COMPONLY"
byte = imm_flag
word = @d_compile, 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 | showcr_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 = showcr_flag
word = @d_trailing, 0, @_prat_
// PRINT TOS
char d_prtos = "."
byte = showcr_flag
word = @d_prat, 0, @_prval_
// PRINT TOS HEX
char d_prtoshex = "$."
byte = showcr_flag
word = @d_prtos, 0, @_prhex_
// PRINT TOS HEX BYTE
char d_prtosbyte = "C$."
byte = showcr_flag
word = @d_prtoshex, 0, @_prbyte_
// EMIT
char d_emit = "EMIT"
byte = 0
word = @d_prtosbyte, 0, @putc
// CR
char d_cr = "CR"
byte = 0
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 = showcr_flag
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 | showcr_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 = 0
word = @d_show, 0, @_showstack_
// SHOW RSTACK
char d_showrstack = "SHOWRSTACK"
byte = 0
word = @d_showstack, 0, @_showrstack_
// TRACE ON
char d_tron = "TRON"
byte = 0
word = @d_showrstack, 0, @_tron_
// TRACE OFF
char d_troff = "TROFF"
byte = 0
word = @d_tron, 0, @_troff_
// SINGLE STEP ON
char d_stepon = "STEPON"
byte = 0
word = @d_troff, 0, @_stepon_
// SINGLE STEP OFF
char d_stepoff = "STEPOFF"
byte = 0
word = @d_stepon, 0, @_stepoff_
// BREAK OUT
char d_brk = "BRK"
byte = 0
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 = 0
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
puts("\n( "); _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 heapmark + 128
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 _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
_compword_(dentry)
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)(heapmark)#0
memcpy(heapmark, 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
puts(" EXIT\n")
pfa = pfa + 2
w = *pfa
fin
if conio:keypressed()
conio:getkey(); conio:getkey()
fin
loop
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
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
Reference in New Issue View Git Blame Copy Permalink