diff --git a/src/mkrel b/src/mkrel index 0b15dc4..ece1bd1 100755 --- a/src/mkrel +++ b/src/mkrel @@ -203,6 +203,7 @@ cp samplesrc/sfm.pla prodos/bld/samples/SFM.PLA.TXT cp samplesrc/sfmsprt.pla prodos/bld/samples/SFMSPRT.PLA.TXT cp samplesrc/fppow.pla prodos/bld/samples/FPPOW.PLA.TXT cp samplesrc/plasma.4th prodos/bld/samples/PLASMA.4TH.TXT +cp samplesrc/grlib.4th prodos/bld/samples/GRLIB.4TH.TXT cp samplesrc/bounce.4th prodos/bld/samples/BOUNCE.4TH.TXT cp utilsrc/apple/mon.pla prodos/bld/samples/MON.PLA.TXT cp utilsrc/apple/zipchip.pla prodos/bld/samples/ZIPCHIP.PLA.TXT diff --git a/src/samplesrc/bounce.4th b/src/samplesrc/bounce.4th index 7a75bfc..71fbeee 100644 --- a/src/samplesrc/bounce.4th +++ b/src/samplesrc/bounce.4th @@ -7,13 +7,22 @@ ?PLASMA ( Load PLASMA if not already ) +: ?GRLIB + " GRLIB" FIND + 0= IF + " GRLIB.4TH" SRC + THEN +; + +?GRLIB ( Load GRLIB if not already ) + 5 VARIABLE BALLCLR 10 VARIABLE BALLX 20 VARIABLE BALLY 10 VARIABLE OLDX 20 VARIABLE OLDY -1 VARIABLE INCX -1 VARIABLE INCY + 1 VARIABLE INCX + 1 VARIABLE INCY : MOVEBALL BALLX @ 0= IF INCX @ NEG INCX ! THEN @@ -22,22 +31,24 @@ BALLY @ 47 = IF INCY @ NEG INCY ! THEN INCX @ BALLX +! INCY @ BALLY +! - BALLCLR @ GRCOLOR DROP - BALLX @ BALLY @ GRPLOT DROP - 0 GRCOLOR DROP - OLDX @ OLDY @ GRPLOT DROP + BALLCLR @ GRCOLOR + BALLX @ BALLY @ GRPLOT + 0 GRCOLOR + OLDX @ OLDY @ GRPLOT BALLX @ OLDX ! BALLY @ OLDY ! ; : BOUNCE - 0 GRMODE DROP + 1 GRMODE DROP + 0 GRDRAWBUF + 0 GRCLEAR BEGIN MOVEBALL ?TERMINAL UNTIL KEY - 40 TEXTMODE DROP + 0 GRMODE DROP ; BOUNCE diff --git a/src/samplesrc/grlib.4th b/src/samplesrc/grlib.4th new file mode 100644 index 0000000..425465f --- /dev/null +++ b/src/samplesrc/grlib.4th @@ -0,0 +1,16 @@ +LOADMOD" GRLIB" + +LOOKUP GRPLOT PLASMA GRPLOT +LOOKUP GRHLIN PLASMA GRHLIN +LOOKUP GRVLIN PLASMA GRVLIN +LOOKUP GRBLT PLASMA GRBLT +LOOKUP GRTILE PLASMA GRTILE +LOOKUP GRTILESTR PLASMA GRTILESTR +LOOKUP GRFILL PLASMA GRFILL +LOOKUP DGRVLB PLASMA DGRVLB +LOOKUP GRCLEAR PLASMA GRCLEAR +LOOKUP GRMODE PLASMA GRMODE +LOOKUP GRSHOW PLASMA GRSHOW +LOOKUP GRSWAP PLASMA GRSWAP +LOOKUP GRDRAWBUF PLASMA GRDRAWBUF +LOOKUP GRCOLOR PLASMA GRCOLOR diff --git a/src/samplesrc/plasma.4th b/src/samplesrc/plasma.4th index 2267956..9467509 100644 --- a/src/samplesrc/plasma.4th +++ b/src/samplesrc/plasma.4th @@ -1,10 +1,19 @@ : IFACE 2 * + @ ; -LOOKUP CMDSYS 3 IFACE PLASMA EXECMOD +LOOKUP CMDSYS 0 IFACE CONSTANT PLASMA_VER LOOKUP CMDSYS 2 IFACE CONSTANT CMDLINE +LOOKUP CMDSYS 3 IFACE PLASMA EXECMOD LOOKUP STRCPY PLASMA STRCPY LOOKUP STRCAT PLASMA STRCAT +: .PLASMAVER + PLASMA_VER 12 RSHIFT $0F AND 48 + EMIT + PLASMA_VER 8 RSHIFT $0F AND 48 + EMIT + 46 EMIT + PLASMA_VER 4 RSHIFT $0F AND 48 + EMIT + PLASMA_VER $0F AND 48 + EMIT +; + : CPYCMD CMDLINE " . " STRCPY DROP ( Need a dummy value for the module name ) 34 WORD CMDLINE SWAP STRCAT DROP ( Quote deliminted string ) @@ -15,9 +24,17 @@ LOOKUP STRCAT PLASMA STRCAT EXECMOD 0< IF ." Failed to exec module" CR THEN ; +: LOADMOD + EXECMOD 0< IF ." Failed to load module" CR THEN +; + : LOADMOD" 34 WORD ( Quote deliminted string ) - EXECMOD 0< IF ." Failed to load module" CR THEN + LOADMOD +; + +: EDIT + " ED" EXECMOD 0< IF ." Failed to run ED" CR ABORT THEN ; : EDIT" @@ -25,21 +42,54 @@ LOOKUP STRCAT PLASMA STRCAT " ED" EXECMOD 0< IF ." Failed to run ED" CR ABORT THEN ; +: CAT + " CAT" EXECMOD 0< IF ." Failed to run CAT" CR ABORT THEN +; + +: CAT" + CPYCMD + " CAT" EXECMOD 0< IF ." Failed to run CAT" CR ABORT THEN +; + +: DEL" + CPYCMD + " DEL" EXECMOD 0< IF ." Failed to run DEL" CR ABORT THEN +; + +: REN" + CPYCMD + " REN" EXECMOD 0< IF ." Failed to run REN" CR ABORT THEN +; + +: COPY" + CPYCMD + " COPY" EXECMOD 0< IF ." Failed to run COPY" CR ABORT THEN +; + +: NEWDIR" + CPYCMD + " NEWDIR" EXECMOD 0< IF ." Failed to run NEWDIR" CR ABORT THEN +; + + ( LOADMOD" FILEIO" FILEIO is already available in plforth ) LOOKUP FILEIO CONSTANT FILEIOAPI FILEIOAPI 0 IFACE PLASMA GETPFX FILEIOAPI 1 IFACE PLASMA SETPFX +: .PFX + HERE GETPFX HERE (.") +; + +: SETPFX" + 34 WORD SETPFX DROP +; + ( LOADMOD" CONIO" CONIO is already available in plforth ) LOOKUP CONIO CONSTANT CONIOAPI CONIOAPI 3 IFACE PLASMA HOME CONIOAPI 4 IFACE PLASMA GOTOXY -CONIOAPI 7 IFACE PLASMA TEXTMODE -CONIOAPI 8 IFACE PLASMA GRMODE -CONIOAPI 9 IFACE PLASMA GRCOLOR -CONIOAPI 10 IFACE PLASMA GRPLOT CONIOAPI 11 IFACE PLASMA TONE CONIOAPI 12 IFACE PLASMA RAND - diff --git a/src/toolsrc/plforth.pla b/src/toolsrc/plforth.pla index 5321f43..4248e92 100644 --- a/src/toolsrc/plforth.pla +++ b/src/toolsrc/plforth.pla @@ -4,550 +4,9 @@ include "inc/fileio.plh" include "inc/conio.plh" include "inc/longjmp.plh" // -// FORTH dictionary layout -// -// bytes usage -// ----- ----- -// [1] name length -// [1..255] name -// [1] FFA (flag field address) -// [2] LFA (link field address) -// [2] CFA (code field address) -// [2..] PFA (param field address) -// - -// -// Mask and flags for dictionary entries -// -const param_flag = $02 -const itc_flag = $04 -const inline_flag = $08 -const inlinew_flag = $10 -const imm_flag = $20 -const componly_flag = $40 -const hidden_flag = $80 -// -// Predefine instrinsics -// -predef _drop_(a)#0, _swap_(a,b)#2, _dup_(a)#2, _dashdup_(a)#1, _over_(a,b,c)#4, _rot_(a,b,c)#3 -predef _add_(a,b)#1, _inc_(a)#1, _inc2_(a)#1, _sub_(a,b)#1, _mul_(a,b)#1, _div_(a,b)#1 -predef _neg_(a)#1, _and_(a,b)#1, _or_(a,b)#1, _xor_(a,b)#1, _not_(a)#1 -predef _mod_(a,b)#1, _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1 -predef _lshift_(a,b)#1, _rshift_(a,b)#1 -predef _cset_(a,b)#0, _cget_(a)#1, _wset_(a,b)#0, _wplusset_(a,b)#0, _wget_(a)#1 -predef _ffa_(a)#1, _lfa_(a)#1, _cfa_(a)#1, _pfa_(a)#1, _allot_(a)#0 -predef _eq_(a,b)#1, _gt_(a,b)#1, _lt_(a,b)#1, _0lt_(a)#1, _0eq_(a)#1 -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, _literal_(a)#0 -predef _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 _forcecomp_#0, pfillw(a)#0, pfillb(a)#0, _colon_#0, _semi_#0 -predef _tors_(a)#0, _fromrs_#1, _toprs_#1, _execute_(a)#0, _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, _tick_#1 -predef _forget_#0, _terminal_#1, _prat_(a)#0, _str_#0, _prstr_#0 -predef _src_(a)#0, _srcstr_#0, _query_#0, _expect_(a,b)#0, _type_(a,b)#0 -predef _vlist_#0, _tron_#0, _troff_#0, _itc_#0, _pbc_#0, _comment_#0 -predef _brkout_#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, _abort_#0 -// DROP -char d_drop = "DROP" -byte = inline_flag -word = 0, @_drop_, $30 -// SWAP -char d_swap = "SWAP" -byte = 0 -word = @d_drop, @_swap_ -// DUP -char d_dup = "DUP" -byte = inline_flag -word = @d_swap, @_dup_, $34 -// -DUP -char d_dashdup = "-DUP" -byte = 0 -word = @d_dup, @_dashdup_ -// OVER -word d_over = "OVER" -byte = 0 -word = @d_dashdup, @_over_ -// ROT -word d_rot = "ROT" -byte = 0 -word = @d_over, @_rot_ -// ADD -char d_add = "+" -byte = inline_flag -word = @d_rot, @_add_, $82 -// ONE PLUS -char d_inc = "1+" -byte = inline_flag -word = @d_add, @_inc_, $8C -// TWO PLUS -char d_inc2 = "2+" -byte = inlinew_flag -word = @d_inc, @_inc2_, $8C8C -// SUB -char d_sub = "-" -byte = inline_flag -word = @d_inc2, @_sub_, $84 -// MUL -char d_mul = "*" -byte = inline_flag -word = @d_sub, @_mul_, $86 -// DIV -char d_div = "/" -byte = inline_flag -word = @d_mul, @_div_, $88 -// DIVMOD -char d_divmod = "/MOD" -byte = inline_flag -word = @d_div, @divmod, $36 -// MOD -char d_mod = "MOD" -byte = inline_flag -word = @d_divmod, @_mod_, $8A -// NEG -char d_neg = "NEG" -byte = inline_flag -word = @d_mod, @_neg_, $90 -// AND -char d_and = "AND" -byte = inline_flag -word = @d_neg, @_and_, $94 -// OR -char d_or = "OR" -byte = inline_flag -word = @d_and, @_or_, $96 -// XOR -char d_xor = "XOR" -byte = inline_flag -word = @d_or, @_xor_, $98 -// NOT -char d_not = "NOT" -byte = inline_flag -word = @d_xor, @_not_, $92 -// LEFT SHIFT -char d_lshift = "LSHIFT" -byte = inline_flag -word = @d_not, @_lshift_, $9A -// RIGHT SHIFT -char d_rshift = "RSHIFT" -byte = inline_flag -word = @d_lshift, @_rshift_, $9C -// EQUALS -char d_eq = "=" -byte = inline_flag -word = @d_rshift, @_eq_, $40 -// GREATER THAN -char d_gt = ">" -byte = inline_flag -word = @d_eq, @_gt_, $44 -// LESS THAN -char d_lt = "<" -byte = inline_flag -word = @d_gt, @_lt_, $46 -// LESS THAN ZERO -char d_0lt = "0<" -byte = inlinew_flag -word = @d_lt, @_0lt_, $4600 // ZERO ISLT -// EQUALS ZERO -char d_0eq = "0=" -byte = inlinew_flag -word = @d_0lt, @_0eq_, $4000 // ZERO ISEQ -// ABS -char d_abs = "ABS" -byte = 0 -word = @d_0eq, @_abs_ -// MIN -char d_min = "MIN" -byte = 0 -word = @d_abs, @_min_ -// MAX -char d_max = "MAX" -byte = 0 -word = @d_min, @_max_ -// CHAR PUT -char d_cset = "C!" -byte = inline_flag -word = @d_max, @_cset_, $70 -// WORD PUT -char d_wset = "!" -byte = inline_flag -word = @d_cset, @_wset_, $72 -// WORD PLUS PUT -char d_wplusset = "+!" -byte = 0 -word = @d_wset, @_wplusset_ -// CHAR GET -char d_cget = "C@" -byte = inline_flag -word = @d_wplusset, @_cget_, $60 -// WORD SET -char d_wget = "@" -byte = inline_flag -word = @d_cget, @_wget_, $62 -// EXECUTE -char d_execute = "EXECUTE" -byte = inline_flag -word = @d_wget, @_execute_, $56 // ICAL -// TO RSTACK -char d_torstk = ">R" -byte = 0 -word = @d_execute, @_tors_ -// FROM RSTACK -char d_fromrstk = "R>" -byte = 0 -word = @d_torstk, @_fromrs_ -// TOP OF RSTACK -char d_toprstk = "R@" -byte = 0 -word = @d_fromrstk, @_toprs_ -// PLASMA SYMBOL LOOKUP -char d_lookup = "LOOKUP" -byte = imm_flag -word = @d_toprstk, @_lookup_ -// PLASMA LINKEAGE -char d_plasma = "PLASMA" -byte = 0 -word = @d_lookup, @_plasma_ -// VARIABLE -char d_var = "VARIABLE" -byte = 0 -word = @d_plasma, @_var_ -// CONSTANT -char d_const = "CONSTANT" -byte = 0 -word = @d_var, @_const_ -// CMOVE -char d_cmove = "CMOVE" -byte = 0 -word = @d_const, @_cmove_ -// MOVE -char d_move = "MOVE" -byte = 0 -word = @d_cmove, @_move_ -// FILL -char d_fill = "FILL" -byte = 0 -word = @d_move, @_fill_ -// HERE -char d_here = "HERE" -byte = 0 -word = @d_fill, @heapmark -// ALLOT -char d_allot = "ALLOT" -byte = 0 -word = @d_here, @_allot_ -// BRANCH -char d_branch = "(BRANCH)" -byte = componly_flag | param_flag -word = @d_allot, @_branch_ -// BRANCH IF 0 -char d_0branch = "(0BRANCH)" -byte = componly_flag | param_flag -word = @d_branch, @_0branch_ -// IF -char d_if = "IF" -byte = imm_flag -word = @d_0branch, @_if_ -// ELSE -char d_else = "ELSE" -byte = imm_flag -word = @d_if, @_else_ -// THEN -char d_then = "THEN" -byte = imm_flag -word = @d_else, @_then_ -// CASE -char d_case = "CASE" -byte = imm_flag -word = @d_then, @_case_ -// OF -char d_of = "OF" -byte = imm_flag -word = @d_case, @_of_ -// ENDOF -char d_endof = "ENDOF" -byte = imm_flag -word = @d_of, @_endof_ -// ENDCASE -char d_endcase = "ENDCASE" -byte = imm_flag -word = @d_endof, @_endcase_ -// DO -char d_do = "DO" -byte = imm_flag -word = @d_endcase, @_do_ -// LEAVE -char d_leave = "LEAVE" -byte = componly_flag -word = @d_do, @_leave_ -// COMPILED LOOP -char d_doloop = "(DOLOOP)" -byte = componly_flag | param_flag -word = @d_leave, @_doloop_ -// LOOP -char d_loop = "LOOP" -byte = imm_flag -word = @d_doloop, @_loop_ -// COMPILED LOOP+ -char d_doplusloop = "(+DOLOOP)" -byte = componly_flag | param_flag -word = @d_loop, @_doplusloop_ -// LOOP -char d_plusloop = "+LOOP" -byte = imm_flag -word = @d_doplusloop, @_plusloop_ -// I -char d_i = "I" -byte = componly_flag -word = @d_plusloop, @_toprs_ -// J -char d_j = "J" -byte = componly_flag -word = @d_i, @_j_ -// BEGIN -char d_begin = "BEGIN" -byte = imm_flag -word = @d_j, @_begin_ -// AGAIN -char d_again = "AGAIN" -byte = imm_flag -word = @d_begin, @_again_ -// UNTIL -char d_until = "UNTIL" -byte = imm_flag -word = @d_again, @_until_ -// WHILE -char d_while = "WHILE" -byte = imm_flag -word = @d_until, @_while_ -// REPEAT -char d_repeat = "REPEAT" -byte = imm_flag -word = @d_while, @_repeat_ -// FORGET -char d_forget = "FORGET" -byte = 0 -word = @d_repeat, @_forget_ -// CREATE -char d_create = "CREATE" -byte = 0 -word = @d_forget, @_create_ -// BUILDS -char d_builds = " ^(dentry+i) + if ^(matchchars + i) <> ^(dentry + i) break fin next @@ -685,7 +729,7 @@ def find(matchchars, matchlen)#1 return dentry fin fin - dentry = *(dentry + ^dentry + 2) + dentry = *(dentry + ^dentry + 4) loop // Not found return 0 @@ -818,6 +862,7 @@ end def warmstart#0 (@_reset_estack)()#0 brk = 0 + brkcfa = 0 RSP = RSTK_SIZE infunc = @keyin inptr = keyinbuf @@ -837,9 +882,10 @@ end // Cold start // def coldstart#0 + warmstart vlist = @d_vlist heaprelease(startheap) - warmstart + buildhashtbl end def docompile(dentry)#0 if state & comp_itc_flag @@ -1028,12 +1074,15 @@ end def _lfa_(dentry)#1 return dentry + ^dentry + 2 end -def _cfa_(dentry)#1 +def _hfa_(dentry)#1 return dentry + ^dentry + 4 end -def _pfa_(dentry)#1 +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") @@ -1124,12 +1173,15 @@ def newdict#0 bldptr++ *bldptr = plist; // Link ptr bldptr = bldptr + 2 - *bldptr = bldptr + 2 b// Point CFA to PFA + *bldptr = 0; // Hash ptr + bldptr = bldptr + 2 + *bldptr = bldptr + 2 // Point CFA to PFA heapalloc(bldptr - vlist + 2) end def _plasma_(a)#0 newdict *(_cfa_(vlist)) = a // PLASMA code address + addhash(vlist) end def _var_(a)#0 newdict @@ -1139,6 +1191,7 @@ def _var_(a)#0 pfillw(heapmark + 3) // Poiner to variable in PFA pfillb($5C) // RET pfillw(a) // Variable storage + addhash(vlist) end def _const_(a)#0 newdict @@ -1147,6 +1200,7 @@ def _const_(a)#0 pfillb($2C) // CONSTANT WORD pfillw(a) pfillb($5C) // RET + addhash(vlist) end def _create_#0 newdict @@ -1243,6 +1297,7 @@ def _semi_#0 _abort_ fin state = state & ~comp_flag + addhash(vlist) end def _forcecomp_#0 word dentry @@ -1516,6 +1571,7 @@ def _forget_#0 if dentry vlist = *_lfa_(dentry) heaprelease(dentry) + buildhashtbl fin end def _cont_#0 @@ -1606,9 +1662,6 @@ def _prstr_#0 fin end def _src_(a)#0 - word filename - byte len - if srclevel >= SRCREFS puts("Too many nested SRC") _abort_ @@ -1623,7 +1676,7 @@ def _src_(a)#0 ^inptr = 0 srclevel++ else - puts("Failed to open "); puts(filename); putln + puts("Failed to open "); puts(a); putln fin end def _srcstr_#0 @@ -1697,6 +1750,20 @@ def _showrstack_#0 depth-- loop end +def _showhash_#0 + word count, dentry + byte i + + for i = 0 to HASH_MASK + count = 0 + dentry = hashtbl[i] + while dentry + count++ + dentry = *_hfa_(dentry) + loop + puti(count); putc(' ') + next +end def _tron_#0 state = state | trace_flag end @@ -1757,7 +1824,6 @@ end // Quit // def _quit_#0 - state = 0 warmstart throw(exit, FALSE) end @@ -1773,7 +1839,6 @@ end // def _restart_#0 coldstart - warmstart throw(exit, FALSE) end // @@ -1788,13 +1853,13 @@ if cmdsys:sysver < $0201 puts("PLASMA >= 2.01 required\n") return fin -warmstart fileio:iobufalloc(4) // Allocate a bunch of file buffers _estkl = ^(@syscall + 1) // Hack to fill in parameter stack locations _estkh = ^(@syscall + 3) -inptr = argNext(argFirst) exit = heapalloc(t_except) startheap = heapmark +coldstart +inptr = argNext(argFirst) if not except(exit) if ^inptr; inptr++; _srcstr_; fin interpret