diff --git a/src/libsrc/apple/grafix.pla b/src/libsrc/apple/grafix.pla index 6a610ab..eea65fa 100644 --- a/src/libsrc/apple/grafix.pla +++ b/src/libsrc/apple/grafix.pla @@ -171,4 +171,5 @@ params:4 = 0 params.6 = 0 syscall($C8, @params) gfxref = params.3 +return modkeep done diff --git a/src/libsrc/apple/hgrfont.pla b/src/libsrc/apple/hgrfont.pla index 7bb06b6..b52782d 100644 --- a/src/libsrc/apple/hgrfont.pla +++ b/src/libsrc/apple/hgrfont.pla @@ -1,3 +1,4 @@ +include "inc/cmdsys.plh" include "inc/hgrtile.plh" // // Apple //e hires character font @@ -137,4 +138,6 @@ byte = $00,$2C,$1A,$00,$00,$00,$00,$00,$00,$2A,$14,$2A,$14,$2A,$00,$00 export def hgrPutStr(x, y, strptr)#0 tileDrawStr(x, y, strptr + 1, ^strptr, @hgrFont + 1024) // Offset into regular char end + +return modkeep done diff --git a/src/libsrc/apple/hgrlib.pla b/src/libsrc/apple/hgrlib.pla index 55f4961..9c93d46 100644 --- a/src/libsrc/apple/hgrlib.pla +++ b/src/libsrc/apple/hgrlib.pla @@ -121,7 +121,7 @@ export asm divmod7(x)#2 BCC + LDY #40 ; > 512 SO CLIP AT MAX LDA #00 - BEQ +++ + BEQ +++ + CMP #140 BCC + ++ SEC @@ -332,7 +332,7 @@ export asm hgrCopySrc(ofst, y, w, h, srcptr)#0 ; LDA ESTKL+0,X ; SRC PTR ; STA SRCL ; LDA ESTKH+0,X -; STA SRCH +; STA SRCH -- LDY ESTKL+3,X ; Y COORD LDA ESTKL+4,X ; HORIZ OFFSET CLC @@ -383,7 +383,7 @@ export asm hgrAndSrc(ofst, y, w, h, srcptr)#0 ; LDA ESTKL+0,X ; SRC PTR ; STA SRCL ; LDA ESTKH+0,X -; STA SRCH +; STA SRCH -- LDY ESTKL+3,X ; Y COORD LDA ESTKL+4,X ; HORIZ OFFSET CLC @@ -435,7 +435,7 @@ export asm hgrXorSrc(ofst, y, w, h, srcptr)#0 ; LDA ESTKL+0,X ; SRC PTR ; STA SRCL ; LDA ESTKH+0,X -; STA SRCH +; STA SRCH -- LDY ESTKL+3,X ; Y COORD LDA ESTKL+4,X ; HORIZ OFFSET CLC @@ -487,7 +487,7 @@ export asm hgrOrSrc(ofst, y, w, h, srcptr)#0 ; LDA ESTKL+0,X ; SRC PTR ; STA SRCL ; LDA ESTKH+0,X -; STA SRCH +; STA SRCH -- LDY ESTKL+3,X ; Y COORD LDA ESTKL+4,X ; HORIZ OFFSET CLC @@ -524,7 +524,7 @@ end //export def hgrPlot(x, y)#0 // word pixptr // byte ofst, pixofst, pmask -// +// // ofst, pixofst = divmod7(x) // pixptr = hgrscan[y] + drawbuff + ofst // pmask = hbmask[pixofst] @@ -570,7 +570,7 @@ end //export def hgrXorPlot(x, y)#0 // word pixptr // byte ofst, pixofst, pmask -// +// // ofst, pixofst = divmod7(x) // pixptr = hgrscan[y] + drawbuff + ofst // pmask = hbmask[pixofst] @@ -615,7 +615,7 @@ end //export def hgrOrPlot(x, y)#0 // word pixptr // byte ofst, pixofst, pmask -// +// // ofst, pixofst = divmod7(x) // pixptr = hgrscan[y] + drawbuff + ofst // pmask = hbmask[pixofst] @@ -661,7 +661,7 @@ end // word pixptr, x // byte lofst, lpixofst, lpmask // byte rofst, rpixofst, rpmask -// +// // if x1 == x2 // hgrPlot(x1, y) // else @@ -779,7 +779,7 @@ end // word pixptr, x // byte lofst, lpixofst, lpmask // byte rofst, rpixofst, rpmask -// +// // if x1 == x2 // hgrPlot(x1, y) // else @@ -894,7 +894,7 @@ end //export def hgrVlin(y1, y2, x)#0 // word pixptr, y, ofst // byte pixofst, pmask, cmask -// +// // if y1 == y2 // hgrPlot(x, y1) // else @@ -925,7 +925,7 @@ end asm _hgrVLinB LDA $2000,Y ; CURHCLR AND TMPL - STA TMPL + STA TMPL LDY ESTKL+3,X ; Y1 COORD end asm _hgrVLinC @@ -954,7 +954,7 @@ end //export def hgrXVlin(y1, y2, x)#0 // word pixptr, y, ofst // byte pixofst, pmask, cmask -// +// // if y1 == y2 // hgrXorPlot(x, y1) // else @@ -985,7 +985,7 @@ end asm _hgrXVLinB LDA $2000,Y ; CURHCLR AND TMPL - STA TMPL + STA TMPL LDY ESTKL+3,X ; Y1 COORD end asm _hgrXVLinC @@ -1036,13 +1036,13 @@ asm _scanBLTA DEX DEX LDA ESTKL+5,X ; X COORDL - STA ESTKL+1,X + STA ESTKL+1,X LDA ESTKH+5,X ; X COORDH - STA ESTKH+1,X + STA ESTKH+1,X LDA ESTKL+4,X ; Y COORDL - STA ESTKL+0,X + STA ESTKL+0,X LDA ESTKH+4,X ; Y COORDH - STA ESTKH+0,X + STA ESTKH+0,X PLA AND #$08 BEQ + @@ -1073,13 +1073,13 @@ asm _scanBLTC DEX DEX LDA ESTKL+5,X ; X COORDL - STA ESTKL+1,X + STA ESTKL+1,X LDA ESTKH+5,X ; X COORDH - STA ESTKH+1,X + STA ESTKH+1,X LDA ESTKL+4,X ; Y COORDL - STA ESTKL+0,X + STA ESTKL+0,X LDA ESTKH+4,X ; Y COORDH - STA ESTKH+0,X + STA ESTKH+0,X PLA AND #$08 BEQ + @@ -1105,7 +1105,7 @@ BLTDONE INX end export def hgrRect(x1, y1, x2, y2)#0 word y - + if x1 == x2 hgrVLin(y1, y2, x1) else @@ -1116,7 +1116,7 @@ export def hgrRect(x1, y1, x2, y2)#0 end export def hgrXorRect(x1, y1, x2, y2)#0 word y - + if x1 == x2 hgrXorVLin(y1, y2, x1) else @@ -1129,7 +1129,7 @@ export def hgrBLT(x, y, w, h, srcptr)#0 word i, j word saveclr byte c - + saveclr = curhclr for j = y to y + h - 1 scanBLT(x, j, w, srcptr) @@ -1156,25 +1156,40 @@ export def hgrBLT(x, y, w, h, srcptr)#0 curhclr = saveclr end export def hgrMode(mode)#1 - if mode - // - // Set HGR mode - // - memset(hgr1, 0, $2000) // Clear HGR page 1 - ^showpage1 - ^showfull - ^showhires - ^showgraphics - drawpage = 1 - drawbuff = hgrbuff[1] - return 1 - fin - // - // Show text mode - // - ^showpage1 - ^showtext - return 0 + when mode + is 0 + // + // Show text mode + // + ^showpage1 + ^showtext + break + is 1 + // + // Set HGR1 mode + // + memset(hgr1, 0, $2000) // Clear HGR1 + ^showpage1 + ^showfull + ^showhires + ^showgraphics + drawpage = 1 + drawbuff = hgrbuff[1] + break + is 2 + // + // Set HGR2 mode + // + memset(hgr2, 0, $2000) // Clear HGR2 + ^showpage1 + ^showfull + ^showhires + ^showgraphics + drawpage = 1 + drawbuff = hgrbuff[1] + break + wend + return mode end export def hgrClear#0 memset(drawbuff, curhclr, drawbuff) // Clear current HGR page @@ -1292,4 +1307,5 @@ _scanBLTB:8 = @hgrOrPlot _scanBLTC:1 = @hgrColor _scanBLTD:1 = @hgrPlot _scanBLTD:8 = @hgrOrPlot +return modkeep done diff --git a/src/libsrc/apple/hgrsprite.pla b/src/libsrc/apple/hgrsprite.pla index 9d5f68e..421eb5c 100644 --- a/src/libsrc/apple/hgrsprite.pla +++ b/src/libsrc/apple/hgrsprite.pla @@ -48,13 +48,13 @@ asm _scanMaskA DEX DEX LDA ESTKL+5,X ; X COORDL - STA ESTKL+1,X + STA ESTKL+1,X LDA ESTKH+5,X ; X COORDH - STA ESTKH+1,X + STA ESTKH+1,X LDA ESTKL+4,X ; Y COORDL - STA ESTKL+0,X + STA ESTKL+0,X LDA ESTKH+4,X ; Y COORDH - STA ESTKH+0,X + STA ESTKH+0,X end asm _scanMaskB JSR $D000 ; HPLOT @@ -81,13 +81,13 @@ asm _scanMaskC DEX DEX LDA ESTKL+5,X ; X COORDL - STA ESTKL+1,X + STA ESTKL+1,X LDA ESTKH+5,X ; X COORDH - STA ESTKH+1,X + STA ESTKH+1,X LDA ESTKL+4,X ; Y COORDL - STA ESTKL+0,X + STA ESTKL+0,X LDA ESTKH+4,X ; Y COORDH - STA ESTKH+0,X + STA ESTKH+0,X end asm _scanMaskD JSR $D000 ; HPLOT @@ -109,7 +109,7 @@ def spriteBLTMask(x, y, w, h, srcptr)#0 word i, j byte pitch byte c - + pitch = (w + 1) / 2 for j = y to y + h - 1 scanMask(x, j, w, srcptr) @@ -127,7 +127,7 @@ def spriteBLTMask(x, y, w, h, srcptr)#0 end export def spriteCompile(w, h, xcenter, ycenter, srcptr)#1 var sprtptr, bytewidth, spritesize, i - + sprtptr = heapalloc(t_sprite) if not sprtptr; return 0; fin bytewidth = (w + 13) / 7 @@ -160,7 +160,7 @@ end export def spriteDup(sprtsrc)#1 var sprtdup byte i - + sprtdup = heapalloc(t_sprite) if not sprtdup; return 0; fin memcpy(sprtdup, sprtsrc, t_sprite) @@ -171,7 +171,7 @@ end export def spriteRead(filestr)#1 var sprtptr, spritesize byte refnum, i - + sprtptr = heapalloc(t_sprite) if not sprtptr; return 0; fin refnum = fileio:open(filestr) @@ -226,7 +226,7 @@ end export def spriteDraw(sprtptr)#0 byte map, pitch, height var ofst, y - + y = sprtptr=>s_ypos ofst, map = divmod7(sprtptr=>s_xpos) if ofst & 1 @@ -252,7 +252,7 @@ end export def spriteDrawXor(sprtptr)#0 byte map, pitch, height var ofst, y - + y = sprtptr=>s_ypos ofst, map = divmod7(sprtptr=>s_xpos) if ofst & 1 @@ -282,7 +282,7 @@ end export def spriteUnDrawList#0 byte i var undrawptr - + undrawptr = undrawList[drawpage] for i = 15 downto 0 if undrawptr=>[i] @@ -294,7 +294,7 @@ end export def spriteDrawList#0 byte i var undrawptr - + undrawptr = undrawList[drawpage] for i = 15 downto 0 if undrawptr=>[i] @@ -311,7 +311,7 @@ end export def spriteUnDrawXorList#0 byte i var undrawptr - + undrawptr = undrawList[drawpage] for i = 0 to 15 if undrawptr=>[i] @@ -323,7 +323,7 @@ end export def spriteDrawXorList#0 byte i var undrawptr - + undrawptr = undrawList[drawpage] for i = 0 to 15 if undrawptr=>[i] @@ -337,7 +337,7 @@ export def spriteDrawXorList#0 end export def spriteAdd(i, sprtptr)#1 var sprtprev - + i = i & 15 sprtprev = drawList[i] drawList[i] = sprtptr @@ -345,7 +345,7 @@ export def spriteAdd(i, sprtptr)#1 end export def spriteDel(i)#1 var sprtprev - + i = i & 15 sprtprev = drawList[i] drawList[i] = 0 @@ -362,4 +362,5 @@ _scanMaskA:1 = @hgrColor _scanMaskB:1 = @hgrPlot _scanMaskC:1 = @hgrColor _scanMaskD:1 = @hgrPlot +return modkeep done diff --git a/src/libsrc/apple/hgrtile.pla b/src/libsrc/apple/hgrtile.pla index a02cfab..9127b68 100644 --- a/src/libsrc/apple/hgrtile.pla +++ b/src/libsrc/apple/hgrtile.pla @@ -55,7 +55,7 @@ TBAS2E = TBAS2L end //export def tileDraw(x, y, tileptr)#0 // var scrnptr -// +// // scrnptr = (scanaddr[y] | drawbuff) + x // scrnptr->[$1C00] = tileptr->[7] // scrnptr->[$1800] = tileptr->[6] @@ -99,7 +99,7 @@ asm _tileDraw end //export def tileXorDraw(x, y, tileptr)#0 // var scrnptr -// +// // scrnptr = (scanaddr[y] | drawbuff) + x // scrnptr->[$1C00] = tileptr->[7] // scrnptr->[$1800] = tileptr->[6] @@ -145,7 +145,7 @@ asm _tileXDraw end //export def tileOrDraw(x, y, tileptr)#0 // var scrnptr -// +// // scrnptr = (scanaddr[y] | drawbuff) + x // scrnptr->[$1C00] = tileptr->[7] // scrnptr->[$1800] = tileptr->[6] @@ -191,7 +191,7 @@ asm _tileODraw end //export def tileAndDraw(x, y, tileptr)#0 // var scrnptr -// +// // scrnptr = (scanaddr[y] | drawbuff) + x // scrnptr->[$1C00] = tileptr->[7] // scrnptr->[$1800] = tileptr->[6] @@ -347,11 +347,11 @@ end export def tileFromText(txtpage, tileset)#0 byte y word txtptr - + txtptr = txtbuff[txtpage & 1] for y = 0 to 23 tileDrawStr(0, y, rowaddr[y] | txtptr, 40, tileset) - next + next end export def tileMode(mode)#1 if mode @@ -431,5 +431,6 @@ _tileDSb:28 = @_tileDSc.28 _tileDSb:33 = @_tileDSc.34 _tileDSb:38 = @_tileDSc.40 _tileDSb:43 = @_tileDSc.46 +return modkeep done diff --git a/src/libsrc/apple/joybuzz.pla b/src/libsrc/apple/joybuzz.pla index 2c831ec..9c60303 100644 --- a/src/libsrc/apple/joybuzz.pla +++ b/src/libsrc/apple/joybuzz.pla @@ -1,3 +1,4 @@ +include "inc/cmdsys.plh" asm asmdefs !SOURCE "vmsrc/plvmzp.inc" SPEAKER = $C030 @@ -57,4 +58,6 @@ GC1DLY NOP ; TIMING BUZZDLY BNE + ; TIMING + BNE GC0READ end + +return modkeep done diff --git a/src/libsrc/apple/portio.pla b/src/libsrc/apple/portio.pla index 31a818a..d612d07 100644 --- a/src/libsrc/apple/portio.pla +++ b/src/libsrc/apple/portio.pla @@ -44,4 +44,5 @@ export def delay(time)#0 call(WAIT,time,0,0,0) end +return modkeep done diff --git a/src/libsrc/fpstr.pla b/src/libsrc/fpstr.pla index 1510720..5527831 100644 --- a/src/libsrc/fpstr.pla +++ b/src/libsrc/fpstr.pla @@ -270,3 +270,6 @@ export def ext2str(ext, str, intdigits, fracdigits, format) ^str = istr - str return str end + +return modkeep +done diff --git a/src/libsrc/fpu.pla b/src/libsrc/fpu.pla index 46410b2..8a9ea04 100644 --- a/src/libsrc/fpu.pla +++ b/src/libsrc/fpu.pla @@ -369,4 +369,6 @@ def reset next return sane:restoreZP(0) end + +return modkeep done diff --git a/src/libsrc/int32.pla b/src/libsrc/int32.pla index 82a3e80..18ffb9a 100644 --- a/src/libsrc/int32.pla +++ b/src/libsrc/int32.pla @@ -360,7 +360,7 @@ _DIV STY DVSIGN ; LSB = SIGN OF DVSR ORA ACCUM32+1 ORA ACCUM32+2 ORA ACCUM32+3 - BEQ - + BEQ - LDA ACCUM32+3 ; DVDND = ACCUM32 BPL + LDA #$81 ; DVDND IS NEG @@ -654,7 +654,7 @@ export def i32tos(i32ptr, strptr)#1 res[t_i32] save word iptr, rem char[12] istr - + iptr = @istr.11 store32(@save) load32(i32ptr) @@ -674,9 +674,10 @@ export def i32tos(i32ptr, strptr)#1 end export def puti32(i32ptr)#0 char[12] i32str - + puts(i32tos(i32ptr, @i32str)) end +return modkeep done diff --git a/src/mkrel b/src/mkrel index b0cd5ff..e537d3c 100755 --- a/src/mkrel +++ b/src/mkrel @@ -209,7 +209,9 @@ rm -rf prodos/scripts mkdir prodos/scripts cp scripts/plasma.4th prodos/scripts/PLASMA.4TH.TXT cp scripts/grlib.4th prodos/scripts/GRLIB.4TH.TXT +cp scripts/hgrlib.4th prodos/scripts/HGRLIB.4TH.TXT cp scripts/bounce.4th prodos/scripts/BOUNCE.4TH.TXT +cp scripts/hrbounce.4th prodos/scripts/HRBOUNCE.4TH.TXT #mkdir prodos/bld/examples #cp samplesrc/examples/ex.1.pla prodos/bld/examples/EX.1.PLA.TXT diff --git a/src/scripts/bounce.4th b/src/scripts/bounce.4th index 71fbeee..32b079c 100644 --- a/src/scripts/bounce.4th +++ b/src/scripts/bounce.4th @@ -24,11 +24,15 @@ 1 VARIABLE INCX 1 VARIABLE INCY +: BEEP 30 10 TONE DROP ; + +: BOOP 10 30 TONE DROP ; + : MOVEBALL - BALLX @ 0= IF INCX @ NEG INCX ! THEN - BALLX @ 39 = IF INCX @ NEG INCX ! THEN - BALLY @ 0= IF INCY @ NEG INCY ! THEN - BALLY @ 47 = IF INCY @ NEG INCY ! THEN + BALLX @ 0= IF INCX @ NEGATE INCX ! BEEP THEN + BALLX @ 39 = IF INCX @ NEGATE INCX ! BEEP THEN + BALLY @ 0= IF INCY @ NEGATE INCY ! BOOP THEN + BALLY @ 47 = IF INCY @ NEGATE INCY ! BOOP THEN INCX @ BALLX +! INCY @ BALLY +! BALLCLR @ GRCOLOR diff --git a/src/scripts/hgrlib.4th b/src/scripts/hgrlib.4th new file mode 100644 index 0000000..b315251 --- /dev/null +++ b/src/scripts/hgrlib.4th @@ -0,0 +1,23 @@ +LOADMOD" HGRLIB" + +LOOKUP HGRPLOT PLASMA HGRPLOT +LOOKUP HGRORPLOT PLASMA HGRORPLOT +LOOKUP HGRXORPLOT PLASMA HGRXORPLOT +LOOKUP HGRHLIN PLASMA HGRHLIN +LOOKUP HGRXORHLIN PLASMA HGRXORHLIN +LOOKUP HGRVLIN PLASMA HGRVLIN +LOOKUP HGRXORVLIN PLASMA HGRXORVLIN +LOOKUP HGRBLT PLASMA HGRBLT +LOOKUP HGRRECT PLASMA HGRRECT +LOOKUP HGRXORRECT PLASMA HGRXORRECT +LOOKUP HGRCOPYSRC PLASMA HGRCOPYSRC +LOOKUP HGRANDSRC PLASMA HGRANDSRC +LOOKUP HGRXORSRC PLASMA HGRXORSRC +LOOKUP HGRORSRC PLASMA HGRORSRC +LOOKUP HGRCOPYDST PLASMA HGRCOPYDST +LOOKUP HGRCLEAR PLASMA HGRCLEAR +LOOKUP HGRMODE PLASMA HGRMODE +LOOKUP HGRSHOW PLASMA HGRSHOW +LOOKUP HGRSWAP PLASMA HGRSWAP +LOOKUP HGRDRAWBUF PLASMA HGRDRAWBUF +LOOKUP HGRCOLOR PLASMA HGRCOLOR diff --git a/src/scripts/hrbounce.4th b/src/scripts/hrbounce.4th new file mode 100644 index 0000000..858bf9c --- /dev/null +++ b/src/scripts/hrbounce.4th @@ -0,0 +1,60 @@ +: ?PLASMA + " IFACE" FIND + 0= IF + " PLASMA.4TH" SRC + THEN +; + +?PLASMA ( Load PLASMA if not already ) + +$6000 HERE - ALLOT ( Reserve HGR2 screen ) + +: ?HGRLIB + " HGRLIB" FIND + 0= IF + " HGRLIB.4TH" SRC + THEN +; + +?HGRLIB ( Load HGRLIB if not already ) + + 5 VARIABLE BALLCLR +10 VARIABLE BALLX +20 VARIABLE BALLY +10 VARIABLE OLDX +20 VARIABLE OLDY + 1 VARIABLE INCX + 1 VARIABLE INCY + +: BEEP 30 10 TONE DROP ; + +: BOOP 10 30 TONE DROP ; + +: MOVEBALL + BALLX @ 0= IF INCX @ NEGATE INCX ! BEEP THEN + BALLX @ 279 = IF INCX @ NEGATE INCX ! BEEP THEN + BALLY @ 0= IF INCY @ NEGATE INCY ! BOOP THEN + BALLY @ 191 = IF INCY @ NEGATE INCY ! BOOP THEN + INCX @ BALLX +! + INCY @ BALLY +! + BALLCLR @ HGRCOLOR + BALLX @ BALLY @ HGRPLOT + 0 HGRCOLOR + OLDX @ OLDY @ HGRPLOT + BALLX @ OLDX ! + BALLY @ OLDY ! +; + +: BOUNCE + 2 HGRMODE DROP + 1 HGRDRAWBUF DROP + 1 HGRSHOW DROP + BEGIN + MOVEBALL + ?TERMINAL + UNTIL + KEY + 0 HGRMODE DROP +; + +( BOUNCE) diff --git a/src/scripts/plasma.4th b/src/scripts/plasma.4th index 691c9f4..24cf81f 100644 --- a/src/scripts/plasma.4th +++ b/src/scripts/plasma.4th @@ -1,10 +1,11 @@ : IFACE 2 * + @ ; -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 +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 +LOOKUP HEAPAVAIL PLASMA FREEMEM : .PLASMAVER PLASMA_VER 12 RSHIFT $0F AND 48 + EMIT @@ -65,7 +66,7 @@ LOOKUP FILEIO CONSTANT FILEIOAPI FILEIOAPI 0 IFACE PLASMA GETPFX FILEIOAPI 1 IFACE PLASMA SETPFX -: .PFX +: PFX. HERE GETPFX DROP HERE (.") ; diff --git a/src/toolsrc/plforth.pla b/src/toolsrc/plforth.pla index 3f9a69b..182e62d 100644 --- a/src/toolsrc/plforth.pla +++ b/src/toolsrc/plforth.pla @@ -8,7 +8,7 @@ include "inc/longjmp.plh" // word vlist word startheap, arg, infunc, inptr, IIP, W -const keyinbuf = $1FF +word keyinbuf = $1FF const SRCREFS = 2 const INBUF_SIZE = 81 byte srclevel = 0 @@ -93,7 +93,8 @@ 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 _add_(a,b)#1, _inc_(a)#1, _inc2_(a)#1, _dec_(a)#1, _dec2_(a)#1 +predef _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 @@ -102,19 +103,20 @@ predef _ffa_(a)#1, _lfa_(a)#1, _hfa_(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, _iscomp_#1 +predef _case_#0, _of_#0, _endof_#0, _endcase_#0, _literal_(a)#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 _forcecomp_#0, pfillw(a)#0, pfillb(a)#0, _colon_#0, _semi_#0 -predef _immediate_#0, _exit_#0, _pad_#1 +predef _immediate_#0, _exit_#0, _pad_#1, _trailing_(a,b)#2 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 _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 _forget_#0, _terminal_#1, _prat_(a)#0, _str_#0, _prstr_#0, _prpstr_#0 +predef _prval_(a)#0, _prbyte_(a)#0, _prhex_(a)#0, _accept_(a,b)#1 predef _src_(a)#0, _srcstr_#0, _query_#0, _expect_(a,b)#0, _type_(a,b)#0 predef _vlist_#0, _tron_#0, _troff_#0, _stepon_#0, _stepoff_#0 predef _itc_#0, _pbc_#0, _comment_#0 -predef _brkout_#0, _brkon_#0, _brkoff_#0, _word_(a)#1, _count_(a)#2 +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 _showhash_#0, _cont_#0, _restart_#0, _bye_#0, _quit_#0 predef _abort_(a)#0, _doabortstr_(a,b)#0, _abortstr_#0 @@ -154,10 +156,18 @@ word = @d_add, 0, @_inc_, $8C char d_inc2 = "2+" byte = inlinew_flag word = @d_inc, 0, @_inc2_, $8C8C +// ONE MINUS +char d_dec = "1-" +byte = inline_flag +word = @d_inc2, 0, @_dec_, $8E +// TWO MINUS +char d_dec2 = "2-" +byte = inlinew_flag +word = @d_dec, 0, @_dec2_, $8E8E // SUB char d_sub = "-" byte = inline_flag -word = @d_inc2, 0, @_sub_, $84 +word = @d_dec2, 0, @_sub_, $84 // MUL char d_mul = "*" byte = inline_flag @@ -175,7 +185,7 @@ char d_mod = "MOD" byte = inline_flag word = @d_divmod, 0, @_mod_, $8A // NEG -char d_neg = "NEG" +char d_neg = "NEGATE" byte = inline_flag word = @d_mod, 0, @_neg_, $90 // AND @@ -214,10 +224,18 @@ word = @d_eq, 0, @_gt_, $44 char d_lt = "<" byte = inline_flag word = @d_gt, 0, @_lt_, $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_lt, 0, @_0lt_, $4600 // ZERO ISLT +word = @d_ult, 0, @_0lt_, $4600 // ZERO ISLT // EQUALS ZERO char d_0eq = "0=" byte = inlinew_flag @@ -286,18 +304,10 @@ word = @d_plasma, 0, @_var_ char d_const = "CONSTANT" byte = 0 word = @d_var, 0, @_const_ -// COMPILING? -char d_iscomp = "?COMP" -byte = 0 -word = @d_const, 0, @_iscomp_ -// CMOVE -char d_cmove = "CMOVE" -byte = 0 -word = @d_iscomp, 0, @_cmove_ // MOVE char d_move = "MOVE" byte = 0 -word = @d_cmove, 0, @_move_ +word = @d_const, 0, @_move_ // FILL char d_fill = "FILL" byte = 0 @@ -414,7 +424,7 @@ word = @d_repeat, 0, @_forget_ char d_create = "CREATE" byte = 0 word = @d_forget, 0, @_create_ -// BUILDS +// BUILDS ( same as CREATE ) char d_builds = " 0 char d_abort = "ABORT" byte = 0 word = @d_quit, 0, @_abort_ @@ -586,14 +608,22 @@ word = @d_abort, 0, @_doabortstr_ char d_abortstr = "ABORT\"" byte = imm_flag word = @d_doabortstr, 0, @_abortstr_ -// RESTART -char d_restart = "RESTART" +// COLD RESTART +char d_restart = "COLD" byte = 0 word = @d_abortstr, 0, @_restart_ +// COMMENT +char d_comment = "(" +byte = imm_flag +word = @d_restart, 0, @_comment_ + +// +// PLFORTH custom words +// // BYE char d_bye = "BYE" byte = 0 -word = @d_restart, 0, @_bye_ +word = @d_comment, 0, @_bye_ // SHOW DEFINITION char d_show = "SHOW" byte = 0 @@ -627,13 +657,13 @@ char d_stepoff = "STEPOFF" byte = 0 word = @d_stepon, 0, @_stepoff_ // BREAK OUT -char d_brkout = "BRKOUT" +char d_brk = "BRK" byte = 0 -word = @d_stepoff, 0, @_brkout_ +word = @d_stepoff, 0, @_brk_ // BREAK ON char d_brkon = "BRKON" byte = 0 -word = @d_brkout, 0, @_brkon_ +word = @d_brk, 0, @_brkon_ // BREAK OFF char d_brkoff = "BRKOFF" byte = 0 @@ -646,14 +676,13 @@ word = @d_brkoff, 0, @_itc_ char d_pbc = "PBC" byte = 0 word = @d_itc, 0, @_pbc_ -// COMMENT -char d_comment = "(" -byte = imm_flag -word = @d_pbc, 0, @_comment_ +// +// Start of vocabulary +// // LIST VOCAB char d_vlist = "VLIST" byte = 0 -word = @d_comment, 0, @_vlist_ +word = @d_pbc, 0, @_vlist_ // // Helper routines // @@ -666,7 +695,8 @@ def keyin#0 repeat puts(brk ?? " BRK\n" :: " OK\n") - inptr = gets(state & comp_flag ?? ']'|$80 :: '>'|$80) + inptr = gets(state & comp_flag ?? ']'|$80 :: '>'|$80) + keyinbuf = inptr // Save if needed until ^inptr ^(inptr + ^inptr + 1) = 0 // NULL terminate inptr++ @@ -762,8 +792,7 @@ def find(matchchars, matchlen)#1 fin dentry = *(dentry + ^dentry + 4) loop - // Not found - return 0 + return 0 // Not found end // // Convert input into number @@ -1038,6 +1067,12 @@ end def _inc2_(a) return a + 2 end +def _dec_(a) + return a - 1 +end +def _dec2_(a) + return a - 2 +end def _sub_(a,b)#1 return a-b end @@ -1176,32 +1211,11 @@ end def _pad_#1 return heapmark + 128 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 +def _trailing_(a,b)#2 + while b and ^(a + b) == ' ' + b-- 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)) + return a, b end def newdict#0 word bldptr, plist, namechars, namelen @@ -1557,28 +1571,41 @@ def _forget_#0 buildhashtbl fin end -def _cont_#0 - if brk - state = state | exit_flag - else - putc('?') - fin -end -def _iscomp_#1 - return state & comp_flag -end def _query_#0 - inptr = gets('>'|$80) + inptr = gets('?'|$80) ^(inptr + ^inptr + 1) = 0 inptr++ end def _expect_(a,b)#0 - inptr = gets('>'|$80) + word saveinptr + + saveinptr = inptr + memcpy(heapmark + 256, keyinbuf, 80) + inptr = gets('?'|$80) if ^inptr > b ^inptr = b fin ^(inptr + ^inptr + 1) = 0 memcpy(a, inptr + 1, ^inptr) + memcpy(keyinbuf, heapmark + 256, 80) + inptr = saveinptr +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 ^$C000 > 127 @@ -1592,9 +1619,6 @@ def _word_(a)#1 ^wordptr = len return wordptr end -def _prat_(a)#0 - puti(*a) -end def _space_#0 putc(' ') end @@ -1604,6 +1628,18 @@ def _spaces_(a)#0 a-- loop end +def _prval_(a)#0 + puti(a); putc(' ') +end +def _prbyte_(a)#0 + putb(a); putc(' ') +end +def _prhex_(a)#0 + puth(a); putc(' ') +end +def _prat_(a)#0 + puti(*a); putc(' ') +end def _str_#0 word str byte len @@ -1621,7 +1657,7 @@ def _str_#0 fin end def _type_(a,b)#0 - while b + while b and ^a putc(^a) a++ b-- @@ -1641,6 +1677,47 @@ def _prstr_#0 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 if srclevel >= SRCREFS puts("Too many nested SRC") @@ -1760,8 +1837,8 @@ def brkpoint#0 (*_cfa_(brkentry))()#0 fin end -def _brkout_#0 - brkhandle(@d_brkout) +def _brk_#0 + brkhandle(@d_brk) end def _brkon_#0 word dentry @@ -1783,6 +1860,13 @@ 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