diff --git a/src/toolsrc/plforth.pla b/src/toolsrc/plforth.pla index 0c29813..0def663 100644 --- a/src/toolsrc/plforth.pla +++ b/src/toolsrc/plforth.pla @@ -17,73 +17,103 @@ include "inc/cmdsys.plh" // const len_mask = $1F const imm_flag = $20 -const comp_flag = $40 const hidden_flag = $80 // // Predefine instrinsics // -predef _drop_(a)#0, _swap_(a,b)#2 +predef _drop_(a)#0, _swap_(a,b)#2, _dup_(a)#2 predef _add_(a,b)#1, _sub_(a,b)#1, _mul_(a,b)#1, _div_(a,b)#1 predef _cset_(a,b)#0, _cget_(a)#1, _wset_(a,b)#0, _wget_(a)#1 predef _cfa_(a)#1, _lfa_(a)#1 -predef _var_(a)#0, _forget_#0 -predef _vlist_#0, _bye_#0 +predef _create_#0, _builds_#0, _does_#0, _pset_(a)#0, _colon_#0, _semi_#0 +predef _var_(a)#0, _lit_#1, _forget_#0 +predef _vlist_#0, _show_#0, _bye_#0 // DROP char d_drop = "DROP" word = 0, @_drop_, 0 // SWAP char d_swap = "SWAP" -word = @d_drop, @_swap_ +word = @d_drop, @_swap_, 0 +// DUP +char d_dup = "DUP" +word = @d_swap, @_dup_, 0 // ADD char d_add = "+" -word = @d_swap, @_add_ +word = @d_dup, @_add_, 0 // SUB char d_sub = "-" -word = @d_add, @_sub_ +word = @d_add, @_sub_, 0 // MUL char d_mul = "*" -word = @d_sub, @_mul_ +word = @d_sub, @_mul_, 0 // DIV char d_div = "/" -word = @d_mul, @_div_ +word = @d_mul, @_div_, 0 // CHAR SET char d_cset = "C!" -word = @d_div, @_cset_ +word = @d_div, @_cset_, 0 // WORD SET char d_wset = "!" -word = @d_cset, @_wset_ +word = @d_cset, @_wset_, 0 // CHAR GET char d_cget = "C@" -word = @d_wset, @_cget_ +word = @d_wset, @_cget_, 0 // WORD SET char d_wget = "@" -word = @d_cget, @_wget_ +word = @d_cget, @_wget_, 0 char d_var = "VARIABLE" -word = @d_wget, @_var_ +word = @d_wget, @_var_, 0 // HERE char d_here = "HERE" -word = @d_var, @heapmark +word = @d_var, @heapmark, 0 // ALLOT char d_allot = "ALLOT" -word = @d_here, @heapalloc +word = @d_here, @heapalloc, 0 // FORGET char d_forget = "FORGET" -word = @d_allot, @_forget_ +word = @d_allot, @_forget_, 0 +// BUILDS +char d_builds = " ' ' + dentry = find + if dentry + pfa = _pfa_(dentry) + w = *pfa + while w + f = ^w + l = f & len_mask + ^w = l + puts(" "); puts(w); putln + ^w = f + pfa = pfa + 2 + w = *pfa + loop + fin + fin end def _vlist_#0 word d + char f, l d = vlist while d + f = ^d + l = f & len_mask + ^d = l puts(d); puts(" ") - d = *(d + ^d + 1) + ^d = f + d = *(d + l + 1) loop end // // Quit and look for user input // def _quit_#0 - word dentry, cfa, __drop, __isnum + word dentry, __drop, __isnum, __pset __drop = @_drop_ __isnum = @isnum + __pset = @_pset_ + // + // Set flags on words + // + d_semi = d_semi | imm_flag repeat - puts("\nOK") - inptr = gets(':'|$80) + puts(" OK") + inptr = gets('\n'|$80) if ^inptr ^(inptr + ^inptr + 1) = 0 // // Clear high bit of input buffer // - for cfa = 1 to ^inptr - ^(inptr + cfa) = ^(inptr + cfa) & $7F + for dentry = 1 to ^inptr + ^(inptr + dentry) = ^(inptr + dentry) & $7F next inptr++ repeat @@ -257,16 +387,29 @@ def _quit_#0 if ^inptr > ' ' dentry = find if dentry - exec(_cfa_(dentry)) + if (not state & comp_flag) or (^dentry & imm_flag) + exec(dentry) + else + //puts("Compile "); puts(dentry); putln + _pset_(dentry) + fin elsif not __isnum()#1 - __drop()#0 - puts("? No match\n") - ^inptr = 0 + __drop()#0 + puts("? No match\n") + ^inptr = 0 + if state // Undo compilation state + heaprelease(vlist) + vlist = *_lfa_(vlist) + state = 0 + fin + elsif state & comp_flag + _pset_(@d_lit) + __pset()#0 // Poke literal value into PFA fin fin until ^inptr < ' ' fin - until exit + until state & exit_flag end _quit_ done