From 50ae7f1361b2818b5214e57e85ae894fe138a590 Mon Sep 17 00:00:00 2001 From: mgcaret Date: Mon, 1 Jul 2019 10:33:44 -0700 Subject: [PATCH] initial full commit --- LICENSE | 24 + README.md | 41 + asm/compiler.s | 158 + asm/env-dictionary.s | 58 + asm/fcode.s | 1372 +++++ asm/forth-dictionary.s | 6914 ++++++++++++++++++++++ asm/interpreter.s | 1078 ++++ asm/mathlib.s | 384 ++ asm/memmgr.s | 626 ++ asm/system.s | 207 + build.sh | 11 + config.inc | 84 + docs/getting_started.md | 228 + docs/internals.md | 262 + docs/porting.md | 167 + fcode-modules/editor.fs | 72 + fcode-modules/makemod.sh | 12 + fcode-modules/test.fs | 5 + forth.s | 29 + inc/equates.inc | 52 + inc/macros.inc | 396 ++ platforms/IIgs/IIgs.l | 15 + platforms/IIgs/IIgs.s | 203 + platforms/IIgs/README.md | 124 + platforms/IIgs/build.sh | 9 + platforms/IIgs/platform-config.inc | 3 + platforms/IIgs/platform-include.inc | 108 + platforms/IIgs/platform-lib.s | 594 ++ platforms/IIgs/platform-words.s | 207 + platforms/W65C816SXB/README.md | 85 + platforms/W65C816SXB/W65C816SXB.l | 16 + platforms/W65C816SXB/W65C816SXB.s | 51 + platforms/W65C816SXB/build.sh | 9 + platforms/W65C816SXB/fcode/hardware.fs | 53 + platforms/W65C816SXB/fcode/romloader.fs | 350 ++ platforms/W65C816SXB/fs/message.fs | 26 + platforms/W65C816SXB/mkromfs.rb | 34 + platforms/W65C816SXB/platform-config.inc | 1 + platforms/W65C816SXB/platform-lib.s | 309 + platforms/W65C816SXB/platform-words.s | 56 + 40 files changed, 14433 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 asm/compiler.s create mode 100644 asm/env-dictionary.s create mode 100644 asm/fcode.s create mode 100644 asm/forth-dictionary.s create mode 100644 asm/interpreter.s create mode 100644 asm/mathlib.s create mode 100644 asm/memmgr.s create mode 100644 asm/system.s create mode 100755 build.sh create mode 100644 config.inc create mode 100644 docs/getting_started.md create mode 100644 docs/internals.md create mode 100644 docs/porting.md create mode 100644 fcode-modules/editor.fs create mode 100755 fcode-modules/makemod.sh create mode 100644 fcode-modules/test.fs create mode 100644 forth.s create mode 100644 inc/equates.inc create mode 100644 inc/macros.inc create mode 100644 platforms/IIgs/IIgs.l create mode 100644 platforms/IIgs/IIgs.s create mode 100644 platforms/IIgs/README.md create mode 100755 platforms/IIgs/build.sh create mode 100644 platforms/IIgs/platform-config.inc create mode 100644 platforms/IIgs/platform-include.inc create mode 100644 platforms/IIgs/platform-lib.s create mode 100644 platforms/IIgs/platform-words.s create mode 100644 platforms/W65C816SXB/README.md create mode 100644 platforms/W65C816SXB/W65C816SXB.l create mode 100644 platforms/W65C816SXB/W65C816SXB.s create mode 100755 platforms/W65C816SXB/build.sh create mode 100644 platforms/W65C816SXB/fcode/hardware.fs create mode 100644 platforms/W65C816SXB/fcode/romloader.fs create mode 100644 platforms/W65C816SXB/fs/message.fs create mode 100755 platforms/W65C816SXB/mkromfs.rb create mode 100644 platforms/W65C816SXB/platform-config.inc create mode 100644 platforms/W65C816SXB/platform-lib.s create mode 100644 platforms/W65C816SXB/platform-words.s diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e1bc926 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Except where noted in individual files/functions the following license applies +to OF816: + +Copyright 2019 Michael Guidero + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of +conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of +conditions and the following disclaimer in the documentation and/or other materials provided +with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..6d74030 --- /dev/null +++ b/README.md @@ -0,0 +1,41 @@ +# OF816 +OF816 is a [65C816](https://www.westerndesigncenter.com/wdc/w65c816s-chip.cfm) +Forth implementation heavily inspired by +[Open Firmware (IEEE 1275-1994)](https://www.openfirmware.info/Welcome_to_OpenBIOS). + +Note that OF816 is *not* an Open Firmware implmentation (yet), but it has the +potential (and groundwork has been done) for it to become one. + +## Features + +Among its many features are: + * Mostly platform-independent. OF816 can be ported easily to new systems. + * Ports currently exist for the W65C816SXB and the Apple IIgs. + * New ports require the implementation of a handful of routines. + * Simple instantiation of one or more Forths in a system. + * 32-bit cells. + * Optional [FCode](https://www.openfirmware.info/Forth/FCode) support + (less Device Tree and Package functions). + * [ANS Forth](http://lars.nocrew.org/dpans/dpans.htm) + * Core, most of Core Ext, Exception, Search Order, and Search Order Ext word + sets. + * Smattering of words from other sets. + +## Goal + +The goal of OF816 is to help get 65C816-based projects off the ground in terms +of development and testing. With a little effort it can be brought up on a new +system and used to play around with new hardware. + +OF816 is not designed for speed. While reasonably performant, the primary goal +was compatibility with 32-bit Open Firmware's core word set, cell size, and +FCode. This allows the possibility of re-using existing Forth source and FCode +to develop hardware drivers, and potentially developing OF816 into a full Open +Firmware implementation. + +## Resources + +In addition to the links above, please see the ``LICENSE`` file, ``docs\``, and +the directories under ``platforms\``. + +OF816 is licensed under a two-clause BSD license. diff --git a/asm/compiler.s b/asm/compiler.s new file mode 100644 index 0000000..731fc05 --- /dev/null +++ b/asm/compiler.s @@ -0,0 +1,158 @@ +; Compiler helpers & primitives + +; Compile a byte to the dictionary +; preserves registers +.proc _cbytea + phy + ldy #$0000 + sep #SHORT_A + sta [DHERE],y + rep #SHORT_A + inc DHERE + bne :+ + inc DHERE+2 +: ply + rts +.endproc + +; Compile a 16-bit word +.proc _cworda + jsr _cbytea + xba + jsr _cbytea + xba + rts +.endproc + +; Compile a 32-bit cell +.proc _ccellay + pha + tya + jsr _cworda + pla + jsr _cworda + rts +.endproc + +; Make a word link in the dictionary, stores a link to the previous word into the +; dictionary, and sets LAST to this link +.proc _w_link + ldy #SV_CURRENT+2 + lda [SYSVARS],y ; get CURRENT (compiler) wordlist address + sta YR+2 + dey + dey + lda [SYSVARS],y + sta YR + ldy #$0002 + lda [YR],y ; get LAST entry for the compiler word list + pha ; save on stack + dey + dey + lda [YR],y + pha + lda DHERE ; get HERE + sta [YR],y ; and put into CURRENT wordlist + iny + iny + lda DHERE+2 + sta [YR],y + ply ; get the old LAST for the compiler word list + pla + jsr _ccellay ; and compile the link + rts +.endproc + +; make a dictionary entry, return with flags/XT address in AY +.proc _mkentry + jsr _2parm + jsr _popxr ; name length + jsr _popwr ; name address + lda XR + cmp #NAMEMSK + bcs badword + clc ; see if we are in danger of putting the new + adc DHERE ; word's first several bytes across a bank boundary + bcs nextbank ; yes we it will + clc + adc #(4+1+1+4) ; (link size + name len byte + flag byte + jsl ) + bcc :+ ; it won't, just go make the entry +nextbank: stz DHERE ; move dictionary pointer to next bank + inc DHERE+2 +: jsr _w_link ; make link, sets LAST to HERE + lda XR + ora #$80 + jsr _cbytea ; compile name length + ldy #$0000 +: cpy XR + bcs done + lda [WR],y + and #$7F ; normalize + jsr _cupper ; and convert to upper case + jsr _cbytea + iny + bne :- +done: lda DHERE+2 + ldy DHERE + pha + phy + lda #$00 + jsr _cbytea ; default flags + ply + pla + rts +badword: ldy #<-19 + lda #>-19 + jmp _throway +.endproc + +.proc _lmkentry + jsr _mkentry + rtl +.endproc + +.if 0 +; Compile data pointed at [WR], length in XR to dictionary +.proc _cdata + ldy #.loword(func) + lda #.hiword(func) + jmp _str_op_ay +func: jsr _cbytea + clc + rts +.endproc + +; Compile (c-addr u) at top of stack into dictionary +.proc _csdata + ldy #.loword(_cdata::func) + lda #.hiword(_cdata::func) + jmp _str_op_ays +.endproc +.endif + +; Compile a JSL to the dictionary +; with target in AY +.proc _cjsl + pha + phy + lda #opJSL +doit: jsr _cbytea + pla + jsr _cworda + pla + jsr _cbytea + rts +.endproc + +; Compile a JSL to the dictionary +; with target in AY +.proc _cjml + pha + phy + lda #opJML + bra _cjsl::doit +.endproc + + + + diff --git a/asm/env-dictionary.s b/asm/env-dictionary.s new file mode 100644 index 0000000..ad6335a --- /dev/null +++ b/asm/env-dictionary.s @@ -0,0 +1,58 @@ + +; Environmental Queries dictionary + +; See config.inc for the options that control the conditionals here +; If max_search_order is > 0, then more entries or overridden entries +; can be placed into the environmental queries dictionary by doing: +; $ENV?-WL SET-CURRENT and then defining the new values (usually via +; VALUE or 2VALUE). + +dstart "env" + +; magic word in case user makes this the only dictionary in the search order. +; it will bail the user out by executing the FORTH word +.if max_search_order > 0 +dword XYZZY,"XYZZY",F_IMMED +.else +hword XYZZY,"XYZZY",F_IMMED +.endif + ENTER + .dword FORTH + EXIT +eword + +.if env_query_level > 0 + +; Environmental queries +denvq xCOUNTEDSTR,"/COUNTED-STRING",$FF +denvq xHOLD,"/HOLD",word_buf_size +.if pad_size > 0 +denvq xPAD,"/PAD",pad_size +.endif +denvq xADDRU,"ADDRESS-UNIT-BITS",8 +denvq xFLOORED,"FLOORED",$FFFFFFFF +denvq xMAXCHAR,"MAX-CHAR",$FF +denvq xMAXD,"MAX-D",$FFFFFFFF,$7FFFFFFF +denvq xMAXN,"MAX-N",$7FFFFFFF +denvq xMAXU,"MAX-U",$FFFFFFFF +denvq xMAXUD,"MAX-UD",$FFFFFFFF,$FFFFFFFF +denvq xRSTKC,"RETURN-STACK-CELLS",64 +denvq xSTKC,"STACK-CELLS",64 +.if env_query_level > 1 +denvq xCORE,"CORE",$FFFFFFFF +denvq xEXCEPTION,"EXCEPTION",$FFFFFFFF +denvq xEXCEPTION_EXT,"EXCEPTION-EXT",$FFFFFFFF +.endif +.if include_fcode +denvq xFCODE,"FCODE",$FFFFFFFF +.endif +.if max_search_order > 0 +.if env_query_level > 1 +denvq xSEARCH_ORDER,"SEARCH-ORDER",$FFFFFFFF +denvq xSEARCH_ORDER_EXT,"SEARCH-ORDER-EXT",$FFFFFFFF +.endif +denvq xWORDLISTS,"WORDLISTS",max_search_order +.endif + +.endif +dend diff --git a/asm/fcode.s b/asm/fcode.s new file mode 100644 index 0000000..6575ffd --- /dev/null +++ b/asm/fcode.s @@ -0,0 +1,1372 @@ +; FCode support +; Built-in (ROM) FTables overlap where possible to save space. +; FCode fetch is in assembly for speed. Most of the rest of the things are to support +; the "FCode" way of doing things, and managing the tables in RAM. + +.define trace_fcode 0 + +; FCODE->XT tables +; Initially the FCode table pointers point to the ROM tables +; the tables are copy-on-write, whereupon each table will be copied to RAM when +; new-token or set-token are called. memory for the table will be via alloc-mem +; byte-load will also save the local fcode tables and temporarily reset the to the ROM +; tables +; end0 and end1 reset the local fcode tables to the ROM, freeing RAM used by them +; since the purpose of fcode is to be space-efficient, hopefully this results in +; space-efficiency + +; Almost all of the non-reserved & non-historical FCodes from table 0 are implemented +; to some degree. Initially, INSTANCE is not supported but can be added later. +.proc fcrom0 + FCIMM FCEND ; 0x00 + FCIMM FERROR ; 0x01-0x0F = prefixes for other tables + FCIMM FERROR ; these wont normally be executed because an fcode + FCIMM FERROR ; fetch will never return one of thes + FCIMM FERROR ; that being said, get-token *will* return these + FCIMM FERROR ; entries + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM B_LIT ; 0x10 b(lit) + FCIMM B_TICK ; b(') + FCIMM B_QUOTE ; b(") + FCIMM BBRANCH ; bbranch + FCIMM BQBRANCH ; b?branch + FCIMM B_LOOP ; b(loop) + FCIMM B_PLOOP ; b(+loop) + FCIMM B_DO ; b(do) + FCIMM B_QDO ; b(?do) + .dword IX + .dword JX + FCIMM B_LEAVE ; b(leave) + FCIMM B_OF ; b(of) + .dword EXECUTE + .dword PLUS + .dword MINUS + .dword MULT ; 0x20 + .dword DIV + .dword MOD + .dword LAND + .dword LOR + .dword LXOR + .dword INVERT + .dword LSHIFT + .dword RSHIFT + .dword ARSHIFT + .dword DIVMOD + .dword UDIVMOD + .dword NEGATE + .dword ABS + .dword MIN + .dword MAX + .dword PtoR ; 0x30 + .dword RtoP + .dword RCOPY + .dword DEXIT + .dword ZEROQ + .dword ZERONEQ + .dword ZEROLT + .dword ZEROLTE + .dword ZEROGT + .dword ZEROGTE + .dword SLT + .dword SGT + .dword EQUAL + .dword NOTEQUAL + .dword UGT + .dword ULTE + .dword ULT ; 0x40 + .dword UGTE + .dword SGTE + .dword SLTE + .dword BETWEEN + .dword WITHIN + .dword DROP + .dword DUP + .dword OVER + .dword SWAP + .dword ROT + .dword NROT + .dword TUCK + .dword NIP + .dword PICK + .dword ROLL + .dword QDUP ; 0x50 + .dword DEPTH + .dword TWODROP + .dword TWODUP + .dword TWOOVER + .dword TWOSWAP + .dword TWOROT + .dword TWODIV + .dword UTWODIV + .dword TWOMULT + .dword SCHAR + .dword SWORD + .dword SLONG + .dword SCELL + .dword CAPLUS + .dword WAPLUS + .dword LAPLUS ; 0x60 + .dword NAPLUS + .dword CHARPLUS + .dword WAINCR + .dword LAINCR + .dword CELLPLUS + .dword CHARS + .dword SWORDMULT + .dword SLONGMULT + .dword CELLS + .dword ON + .dword OFF + .dword PSTORE + .dword FETCH + .dword LFETCH + .dword WFETCH + .dword WFETCHS ; 0x70 + .dword CFETCH + .dword STORE + .dword LSTORE + .dword WSTORE + .dword CSTORE + .dword TWOFETCH + .dword TWOSTORE + .dword MOVE + .dword FILL + .dword COMP + .dword NOOP + .dword LWSPLIT + .dword WLJOIN + .dword LBSPLIT + .dword BLJOIN + .dword WBFLIP ; 0x80 + .dword UPC + .dword LCC + .dword PACK + .dword COUNT + .dword BODYr + .dword rBODY + .dword FCODE_REVISION + .dword SPAN + .dword UNLOOP + .dword EXPECT + .dword ALLOC + .dword FREE + .dword KEYQ + .dword KEY + .dword EMIT + .dword TYPE ; 0x90 + .dword pCR + .dword CR + .dword NOUT + .dword NLINE + .dword PHOLD + .dword PBEGIN + .dword PUDONE + .dword PSIGN + .dword PUNUM + .dword PUNUMS + .dword UDOT + .dword UDOTR + .dword DOT + .dword DOTR + .dword DOTS + .dword BASE ; 0xA0 + FCIMM FERROR ; historical CONVERT + .dword dNUMBER + .dword DIGIT + .dword MINUSONE + .dword ZERO + .dword ONE + .dword TWO + .dword THREE + .dword BL + .dword BS + .dword BELL + .dword BOUNDS + .dword HERE + .dword ALIGNED + .dword WBSPLIT + .dword BWJOIN ; 0xB0 + FCIMM B_MARK ; b(resolve) + FCIMM FERROR ; obsolete set-token-table + FCIMM FERROR ; obsolete set-table + .dword NEW_TOKEN + .dword NAMED_TOKEN + FCIMM B_COLON + FCIMM pVALUE ; subject to INSTANCE + FCIMM pVARIABLE ; subject to INSTANCE + FCIMM B_CONSTANT ; b(constant) + FCIMM pCREATE ; b(create) -> pCREATE + FCIMM pDEFER ; subject to INSTANCE + FCIMM pBUFFER ; subject to INSTANCE + FCIMM B_FIELD ; b(field) + FCIMM FERROR ; obsolete b(code) (re-use OK for native words?) + FCIMM FERROR ; INSTANCE ; 0xC0 + FCIMM FERROR ; reserved + FCIMM SEMI ; B_SEMI, same as SEMI for now + FCIMM B_TO + FCIMM B_CASE ; b(case) + FCIMM B_ENDCASE ; b(endcase) + FCIMM B_ENDOF ; b(endof) + .dword PNUM + .dword PNUMS + .dword PDONE + .dword EXTERNAL_TOKEN + .dword dFIND + .dword OFFSET16 + .dword EVALUATE + FCIMM FERROR + FCIMM FERROR + .dword CCOMMA ; 0xD0 + .dword WCOMMA + .dword LCOMMA + .dword COMMA + .dword UMMULT + .dword UMDIVMOD + FCIMM FERROR + FCIMM FERROR + .dword DPLUS + .dword DMINUS + .dword GET_TOKEN + .dword SET_TOKEN + .dword STATE + .dword COMPILECOMMA + .dword BEHAVIOR + FCIMM FERROR ; 0xDF-0xEF reserved + FCIMM FERROR ; 0xE0 + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + .dword START0 ; 0xF0 + .dword START1 + .dword START2 + .dword START4 + FCIMM FERROR ; 0xF4-0xFB reserved + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR ; 0xFC explicitly FERROR + .dword VERSION1 + FCIMM FERROR ; obsolete 4-byte-id + .dword FCEND ; 0xFF +.endproc + +.proc fcrom2 + FCIMM FERROR ; 0x200 + FCIMM FERROR ; device-name + FCIMM FERROR ; my-args + FCIMM FERROR ; my-self + FCIMM FERROR ; find-package + FCIMM FERROR ; open-package + FCIMM FERROR ; close-package + FCIMM FERROR ; find-method + FCIMM FERROR ; call-package + FCIMM FERROR ; $call-parent + FCIMM FERROR ; my-parent + FCIMM FERROR ; ihandle>phandle + FCIMM FERROR ; reserved + FCIMM FERROR ; my-unit + FCIMM FERROR ; $call-method + FCIMM FERROR ; $open-package + FCIMM FERROR ; 0x210 historical processor-type + FCIMM FERROR ; historical firmware-version + FCIMM FERROR ; historical fcode-version + FCIMM FERROR ; alarm + .dword IS_USER_WORD ; (is-user-word) + .dword NOOP ; suspend-fcode, to be optionally replaced + .dword ABORT + .dword CATCH + .dword THROW + FCIMM FERROR ; user-abort + FCIMM FERROR ; get-my-property + FCIMM FERROR ; DECODE_INT + FCIMM FERROR ; DECODE_STRING + FCIMM FERROR ; get-inherited-property + FCIMM FERROR ; delete-property + FCIMM FERROR ; get-package-property + .dword CPEEK ; 0x220 + .dword WPEEK + .dword LPEEK + .dword CPOKE + .dword WPOKE + .dword LPOKE + .dword WBFLIP + .dword LBFLIP + .dword LBFLIPS + FCIMM FERROR ; historical adr-mask + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + .dword dRBFETCH + .dword dRBSTORE + .dword dRWFETCH + .dword dRWSTORE + .dword dRLFETCH + .dword dRLSTORE + .dword WBFLIPS + .dword LWFLIPS + FCIMM FERROR ; probe + FCIMM FERROR ; probe-virtual + FCIMM FERROR ; reserved + FCIMM FERROR ; child + FCIMM FERROR ; peer + FCIMM FERROR ; next-property + .dword BYTE_LOAD + FCIMM FERROR ; set-args + .dword LEFT_PARSE_STRING + .repeat $aa + FCIMM FERROR ; remaining are reserved + .endrepeat + ; the last 15 XTs overlap with fcrom1 to save space +.endproc + +.proc fcrom1 + FCIMM FERROR ; 0x100 reserved + FCIMM FERROR ; dma-alloc + FCIMM FERROR ; my-address + FCIMM FERROR ; my-space + FCIMM FERROR ; historical memmap + FCIMM FERROR ; free-virtual + FCIMM FERROR ; historical >physical + FCIMM FERROR ; 0x107-0x10E reserved + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR + FCIMM FERROR ; my-params + FCIMM FERROR ; PROPERTY ; 0x110 + FCIMM FERROR ; ENCODE_INT + FCIMM FERROR ; ENCODEPLUS + FCIMM FERROR ; ENCODE_PHYS + FCIMM FERROR ; ENCODE_STRING + FCIMM FERROR ; ENCODE_BYTES + FCIMM FERROR ; reg + FCIMM FERROR ; obsoluete intr + FCIMM FERROR ; driver + FCIMM FERROR ; model + FCIMM FERROR ; device-type + .dword PARSE_2INT ; 0x11b + ; the rest are unimplemented in the ROM, need to be installed later + ; and overlap with fcromnone +.endproc + +.proc fcromnone + .repeat 256 + FCIMM FERROR + .endrepeat +.endproc +fcrom3 = fcromnone ; reserved +fcrom4 = fcromnone ; reserved +fcrom5 = fcromnone ; reserved +fcrom6 = fcromnone ; vendor +fcrom7 = fcromnone ; vendor +fcrom8 = fcromnone ; local codes table 8-f +fcrom9 = fcromnone +fcroma = fcromnone +fcromb = fcromnone +fcromc = fcromnone +fcromd = fcromnone +fcrome = fcromnone +fcromf = fcromnone + +.proc fc_romtab + FCROM fcrom0 + FCROM fcrom1 + FCROM fcrom2 + FCROM fcrom3 + FCROM fcrom4 + FCROM fcrom5 + FCROM fcrom6 + FCROM fcrom7 + FCROM fcrom8 + FCROM fcrom9 + FCROM fcroma + FCROM fcromb + FCROM fcromc + FCROM fcromd + FCROM fcrome + FCROM fcromf +.endproc + +; headerless words related to FCode evaluation + +; ( -- c-addr f ) +; Get the pointer to the current FCode tables, and a flag if the table is in ROM +xdword GET_FTABLES + ENTER + .dword dFCODE_TABLES +dof: .dword FETCH + .dword DUP + ONLIT $7FFFFFFF + .dword LAND + .dword SWAP + ONLIT FC_ROMFLAG + .dword LAND + EXIT +exdword + +; ( u -- c-addr ) +; Get the address of a specific FCode table pointer +; e.g. if u is 1, get the cell containing the address of the table for $1xx +; FCodes +xdword GET_FTABLE_PADDR + ENTER + ONLIT $F + .dword LAND + .dword GET_FTABLES + .dword DROP + .dword SWAP + .dword NAPLUS + EXIT +exdword + +; ( -- ) +; Copy the ROM FCode table list to RAM in preparation for it to be modified +; by set-token, new-token, etc. +xdword SET_MUTABLE_FTABLES + ENTER + .dword GET_FTABLES ; ( -- c-addr f ) + .dword _IF ; ( c-addr f -- c-addr ) + .dword already ; false branch if already in RAM + ONLIT 16*4 ; ( c-addr -- c-addr u ) 16 tables, 4 bytes per pointer + .dword DUP ; ( c-addr u -- c-addr u1 u2 ) + .dword ALLOC ; ( c-addr u1 u2 -- c-addr1 u1 c-addr2 ) + .dword PtoR ; ( c-addr1 u1 c-addr2 -- c-addr1 u1 ) ( R: -- c-addr2 ) + .dword RCOPY ; ( ... c-addr1 u1 c-addr2 ) + .dword SWAP ; ( ... c-addr1 c-addr2 u1 ) + .dword MOVE ; ( c-addr1 c-addr2 u1 -- ) + .dword RtoP ; ( -- c-addr2 ) ( R: c-addr2 -- ) + .dword dFCODE_TABLES ; ( c-addr2 -- c-addr2 c-addr3 ) + .dword STORE ; ( c-addr2 c-addr3 -- ) + EXIT +already: .dword DROP ; ( c-addr -- ) + EXIT +exdword + +; ( u -- a-addr f ) f = 1 if ROM table +xdword GET_FTABLE + ENTER + .dword GET_FTABLE_PADDR + JUMP GET_FTABLES::dof +exdword + +; ( a-addr u -- ) +; set table u address to a-addr +xdword SET_FTABLE + ENTER + .dword SET_MUTABLE_FTABLES ; ( a-addr u -- a-addr u ) + .dword GET_FTABLE_PADDR ; ( a-addr u -- a-addr1 a-addr2 ) + .dword STORE ; ( a-addr1 a-addr2 -- ) + EXIT +exdword + +; ( u -- a-addr ) +; Get ROM ftable address for table u +xdword GET_ROM_FTABLE + ENTER + ONLIT fc_romtab + .dword SWAP + .dword NAPLUS + .dword FETCH + EXIT +exdword + +; ( u -- ) +; Force table u to the ROM table without freeing the existing RAM table +xdword FORCE_ROM_FTABLE + ENTER + .dword DUP ; ( u -- u1 u2 ) + .dword GET_FTABLE ; ( u1 u2 -- u1 a-addr f ) + .dword _IFFALSE ; ( u1 a-addr f -- u1 a-addr ) + .dword already ; is true, already in ROM + .dword DROP ; ( .. u1 ) don't need current address + .dword DUP ; ( u1 -- u1 u2 ) + .dword GET_ROM_FTABLE ; ( u1 u2 -- u1 a-addr ) + .dword SWAP ; ( u1 a-addr -- a-addr u1 ) + .dword SET_FTABLE ; ( a-addr u1 -- ) + EXIT +already: .dword TWODROP ; ( u1 a-addr -- ) + EXIT +exdword + +; ( u -- ) +; Set table u to the ROM table, freeing existing RAM table +xdword SET_ROM_FTABLE + ENTER + .dword DUP ; ( u -- u1 u2 ) + .dword GET_FTABLE ; ( u1 u2 -- u1 a-addr f ) + .dword _IFFALSE ; ( u1 a-addr f -- u1 a-addr ) + .dword already ; is true, already in ROM + .dword ZERO ; ( ... u1 a-addr 0 ) + .dword FREE ; ( ... u1 ) free existing RAM + .dword DUP ; ( u1 -- u1 u2 ) + .dword GET_ROM_FTABLE ; ( u1 u2 -- u1 a-addr ) + .dword SWAP ; ( u1 a-addr -- a-addr u1 ) + .dword SET_FTABLE ; ( a-addr u1 -- ) + EXIT +already: .dword TWODROP ; ( u1 a-addr -- ) + EXIT +exdword + +; ( u -- ) +; Set table u to be a RAM table, allocating memory and copying the existing table +; do nothing if it is already a RAM table +xdword SET_RAM_FTABLE + ENTER + .dword PtoR ; ( u -- ) ( R: u ) + .dword RCOPY ; ( -- u ) + .dword GET_FTABLE ; ( u -- a-addr f ) + .dword _IF ; ( a-addr f -- a-addr ) + .dword already +doset: ONLIT $100*4 ; ( ... a-addr $400 ) + .dword DUP ; ( ... a-addr $400 $400 ) + .dword ALLOC ; ( ... a-addr1 $400 a-addr2 ) + .dword PtoR ; ( ... a-addr1 $400 ) ( R: ... u a-addr2 ) + .dword RCOPY ; ( ... a-addr1 $400 a-addr2 ) + .dword SWAP ; ( ... a-addr1 a-addr2 $400 ) + .dword MOVE ; ( a-addr1 a-addr2 $400 -- ) + .dword RtoP ; ( -- a-addr2 ) + .dword RtoP ; ( -- a-addr u ) + .dword SET_FTABLE ; ( a-addr u -- ) + EXIT +already: .dword RtoP + .dword TWODROP ; ( a-addr -- ) + EXIT +exdword + +; ( -- ) +; set tables 0-7 to ROM tables, freeing any RAM tables +xdword SET_ROM_FTABLE_SYS + ENTER + ONLIT $7 +set1: .dword DUP ; ( n -- n1 n2 ) + .dword SET_ROM_FTABLE ; ( n1 n2 -- n1 ) + .dword QDUP ; ( n1 -- 0 | n1 -- n1 n2 ) + .dword _IF ; ( 0 -- | n1 n2 -- n1 ) + .dword done + .dword DECR ; ( n1 -- n1' ) + JUMP set1 +done: EXIT +exdword + +; ( -- ) +; set tables 8-F to ROM tables, freeing any RAM tables +xdword SET_ROM_FTABLE_PRG + ENTER + ONLIT $F +set1: .dword DUP ; ( n -- n1 n2 ) + .dword SET_ROM_FTABLE ; ( n1 n2 -- n1 ) + .dword DUP ; ( n1 -- n1 n2 ) + ONLIT $8 ; ( n1 n2 -- n1 n2 8 ) + .dword EQUAL ; ( n1 n2 8 -- n1 f ) + .dword _IFFALSE ; ( n1 f -- n1 ) + .dword done + .dword DECR ; ( n1 -- n1' ) + JUMP set1 +done: .dword DROP ; ( n1 -- ) + EXIT +exdword + +; ( a-addr -- ) +; save tables 8-F pointers to a-addr restoring the existing table to ROM vectors +xdword SAVE_PRG_FTABLES + ENTER + .dword SET_MUTABLE_FTABLES ; ( a-addr -- a-addr ) + ONLIT 8 ; ( a-addr -- a-addr 8 ) + .dword GET_FTABLE_PADDR ; ( a-addr 8 -- a-addr1 a-addr2 ) + .dword SWAP ; ( ... a-addr2 a-addr1 ) + ONLIT 8*4 ; ( ... a-addr2 a-addr1 ) + .dword MOVE ; ( ... ) + ONLIT $F +set1: .dword DUP ; ( n -- n1 n2 ) + .dword FORCE_ROM_FTABLE ; ( n1 n2 -- n1 ) + .dword DUP ; ( n1 -- n1 n2 ) + ONLIT $8 ; ( n1 n2 -- n1 n2 8 ) + .dword EQUAL ; ( n1 n2 8 -- n1 f ) + .dword _IFFALSE ; ( n1 f -- n1 ) + .dword done + .dword DECR ; ( n1 -- n1' ) + JUMP set1 +done: .dword DROP ; ( n1 -- ) + EXIT +exdword + +; ( a-addr -- ) +; set tables 8-F to pointers in c-addr, freeing c-addr after restoring, also freeing +; any RAM tables +xdword RESTORE_PRG_FTABLES + ENTER + .dword SET_MUTABLE_FTABLES ; ( a-addr -- a-addr ) + .dword SET_ROM_FTABLE_PRG ; ( a-addr -- a-addr ) + ONLIT 8 ; ( a-addr -- a-addr 8 ) + .dword GET_FTABLE_PADDR ; ( a-addr 8 -- a-addr1 a-addr2 ) + ONLIT 8*4 ; ( a-addr1 a-addr2 -- a-addr1 a-addr2 24 ) + .dword MOVE ; ( a-addr1 a-addr2 24 -- ) + EXIT +exdword + +; save the current state of the FCode internal variables and program-defined memory +; into newly-allocated memory, return address +; ( -- a-addr ) +xdword SAVE_FCODE_STATE + ENTER + ; Allocate memory + ONLIT 8*4+5*4 ; 5 variables plus program-defined table size + .dword ALLOC + .dword PtoR + ; $FCODE-IP and $FCODE-END + .dword dFCODE_IP + .dword FETCH + .dword dFCODE_END + .dword FETCH + .dword RCOPY + .dword TWOSTORE + ; $FCODE-SPREAD and $FCODE-OFFSET + .dword dFCODE_SPREAD + .dword FETCH + .dword dFCODE_OFFSET + .dword FETCH + .dword RCOPY + .dword TWO + .dword NAPLUS + .dword TWOSTORE + ; $FCODE-FETCH + .dword dFCODE_FETCH + .dword FETCH + .dword RCOPY + ONLIT 4 + .dword NAPLUS + .dword STORE + ; Program-defined FCode tables + .dword RCOPY + ONLIT 5 + .dword NAPLUS + .dword SAVE_PRG_FTABLES + .dword RtoP + EXIT +exdword + +; ( a-addr -- ) +xdword RESTORE_FCODE_STATE + ENTER + ; Program-defined FCode Tables + .dword PtoR + .dword RCOPY + ONLIT 5 + .dword NAPLUS + .dword RESTORE_PRG_FTABLES + ; $FCODE-FETCH + .dword RCOPY + ONLIT 4 + .dword NAPLUS + .dword FETCH + .dword dFCODE_FETCH + .dword STORE + ; $FCODE-OFFSET and $FCODE-SPREAD + .dword RCOPY + .dword TWO + .dword NAPLUS + .dword TWOFETCH + .dword dFCODE_OFFSET + .dword STORE + .dword dFCODE_SPREAD + .dword STORE + ; $FCODE-END and $FCODE-IP + .dword RCOPY + .dword TWOFETCH + .dword dFCODE_END + .dword STORE + .dword dFCODE_IP + .dword STORE + ; finally, free memory + .dword RtoP + .dword ZERO + .dword FREE + EXIT +exdword + +; ( fcode# -- a-addr ) +xdword GET_TOKEN_PADDR + ENTER + .dword WBSPLIT ; ( fcode# - u table# ) + .dword GET_FTABLE ; ( u table# -- u tableaddr f ) + .dword DROP ; ( u tableaddr f -- u tableaddr ) + .dword SWAP ; ( u tableaddr -- tableaddr u ) + .dword NAPLUS ; ( tableaddr u -- a-addr ) + EXIT +exdword + +; ( xt f fcode# -- ) +xdword xSET_TOKEN + ENTER + .dword PtoR ; ( xt f fcode# -- xt f ) ( R: fcode# ) + .dword _IF ; ( xt f -- xt ) + .dword notimm + ONLIT FC_IMMFLAG ; + .dword LOR +notimm: .dword SET_MUTABLE_FTABLES + .dword RCOPY + ONLIT 8 + .dword RSHIFT + .dword SET_RAM_FTABLE + .dword RtoP + .dword GET_TOKEN_PADDR + .dword STORE + EXIT +exdword +xSET_TOKEN_code = xSET_TOKEN::code + +.proc lGET_TOKEN + ldy #SV_FCODE_TABLES+2 + lda [SYSVARS],y ; Copy table of tables address + sta WR+2 ; to WR + dey + dey + lda [SYSVARS],y + sta WR + lda STACKBASE+0,x ; now get the table number + xba + and #$0F + asl ; multiply by 4 (cell size) + asl + tay ; and use for index + lda [WR],y ; get table address low word + pha ; save it + iny + iny + lda [WR],y ; high word + sta WR+2 ; now put that in WR + pla + sta WR + lda STACKBASE+0,x ; get token again + and #$FF ; mask in low byte + asl ; multiply by 4 + asl + tay ; and use for index + lda [WR],y ; (y = 2) grab token low byte + sta STACKBASE+0,x ; put in data stack + iny + iny + lda [WR],y + php ; save for flag + and #$7FFF + sta STACKBASE+2,x + ldy #$0000 ; for flag + plp + bpl :+ + dey +: dex ; make room for flag + dex + dex + dex + sty STACKBASE+0,x ; and put it on stack + sty STACKBASE+2,x + rtl +.endproc + +; Increment FCode IP by spread +; Put FCode IP on stack +; Jump to fetch method +; The reasons we do it in this order are: +; * We need the routines that change the spread to be run before the next increment. +; * We would like the IP to point to the address with the FCode that caused an exception. +; The consequences are: +; * byte-load needs to load the address less 1 so that the first increment goes to the +; correct address. +xdword xFCODE_FETCH + dex ; add a stack item, hope there's room! + dex + dex + dex + ldy #SV_FCODE_SPREAD ; get spread + lda [SYSVARS],y + sta XR ; and hold in XR for now + ldy #SV_FCODE_IP ; get IP + lda [SYSVARS],y ; low byte + clc ; now add spread + adc XR + sta [SYSVARS],y ; and write back + sta STACKBASE+0,x ; put on data stack + iny ; go to high byte of IP + iny + lda [SYSVARS],y ; fetch it + adc #$0000 ; in case spread carried + sta [SYSVARS],y ; write back + sta STACKBASE+2,x ; put on data stack + ldy #SV_FCODE_FETCH ; now get XT for fetch function + lda [SYSVARS],y ; and set it up for RUN + pha + iny + iny + lda [SYSVARS],y + ply + LRUN +exdword + +; ( u -- ) skip u bytes of FCode +xdword xFCODE_SKIP + ENTER + .dword dFCODE_SPREAD + .dword FETCH + .dword UMULT + .dword dFCODE_IP + .dword PSTORE + EXIT +exdword + +xdword xFCODE_FETCH_TOKEN + ENTER + .dword xFCODE_FETCH ; ( -- u ) fetch first byte of FCODE + .dword DUP ; ( ... u u' ) + .dword _IF ; ( ... u ) + .dword one ; if zero, one byte token + .dword DUP ; ( ... u u' ) + ONLIT $10 ; ( ... u u' $10 ) + .dword ULT ; ( ... u f ) + .dword _IF ; ( ... u ) + .dword one ; if $10 or more, one-byte token + .dword xFCODE_FETCH ; ( ... u1 u2 ) otherwise fetch low byte + .dword SWAP ; ( ... u2 u1 ) put low byte first + .dword BWJOIN ; and combine into a word +one: EXIT +exdword + +xdword xFCODE_FETCH_NUM16 + ENTER + .dword xFCODE_FETCH ; high byte + .dword xFCODE_FETCH ; low byte + .dword SWAP + .dword BWJOIN + EXIT +exdword + +xdword xFCODE_FETCH_OFFSET + ENTER + .dword dFCODE_OFFSET + .dword FETCH + .dword _IF + .dword offset8 + .dword xFCODE_FETCH_NUM16 + .dword WSX + EXIT +offset8: .dword xFCODE_FETCH + .dword BSX + EXIT +exdword + +xdword xFCODE_FETCH_NUM32 + ENTER + .dword xFCODE_FETCH_NUM16 ; high word + .dword xFCODE_FETCH_NUM16 ; low word + .dword SWAP + .dword WLJOIN + EXIT +exdword + +; Consume a string from the FCode stream and return it in a newly-allocated +; chunk from the heap. This *must* be freed with FREE_MEM +; ( -- c-addr u ) +xdword xFCODE_FETCH_STR + ENTER + .dword xFCODE_FETCH ; ( -- u ) get length of string + .dword DUP ; ( u -- u u' ) + .dword PtoR ; ( u u' -- u ) ( R: u ) + .dword ALLOC ; ( u -- c-addr ) allocate space + .dword ZERO ; ( c-addr -- c-addr count ) +lp: .dword DUP ; ( c-addr count -- c-addr count count' ) + .dword RCOPY ; ( ... c-addr count count' u ) + .dword EQUAL ; ( ... c-addr count f ) + .dword _IFFALSE ; ( ... c-addr count ) are we done? + .dword done ; true branch, yes, finished + .dword TWODUP ; ( ... c-addr count c-addr' count' ) + .dword PLUS ; ( ... c-addr count c-addr2 ) + .dword xFCODE_FETCH ; ( ... c-addr count c-addr2 char ) + .dword SWAP ; ( ... c-addr count char c-addr2 ) + .dword CSTORE ; ( ... c-addr count ) + .dword INCR ; ( ... c-addr count+1 ) + JUMP lp +done: .dword RDROP + EXIT +exdword + +; Compile or execute token based on current state and immediacy of the token +; ( fcode# -- nx... ) +xdword DO_TOKEN + ENTER + ;.dword DOTS + .dword GET_TOKEN + .dword _IF ; is immediate word? + .dword notimm ; no, either compile or execute + .dword TEMPDQ + .dword _IF ; check if requires temp def when interpreting + .dword exec ; it doesn't, just execute + .dword _SMART ; true branch, see if we are interpreting + .dword tempdef ; we are, start temporary definition +exec: .dword EXECUTE ; otherwise execute + EXIT +notimm: .dword _SMART + .dword exec ; execute if interpreting +compile: .dword COMPILECOMMA ; otherwise compile it + EXIT +tempdef: .dword PtoR ; ( xt -- ) ( R: -- xt ) + .dword dTEMPCOLON ; start temporary colon definition + .dword RtoP ; ( -- xt ) ( R: xt -- ) + .dword IMMEDQ ; is base definition immediate? (It usually is) + .dword _IF + .dword compile ; no, compile xt + JUMP exec ; yes, execute xt +exdword + +; FCode evaluator, assumes things were set up correctly by byte-load +xdword xFCODE_EVALUATE + ENTER +lp: .dword dFCODE_END ; ( -- a-addr ) + .dword FETCH ; ( -- f ) + .dword _IFFALSE ; ( f -- ) + .dword done ; true, stop evaluating + .if trace_fcode + ONLIT '[' + .dword EMIT + .dword SPACE + .dword DEPTH + .dword UDOT + .endif + .dword xFCODE_FETCH_TOKEN ; ( -- token ) not ending + .if trace_fcode + .dword dFCODE_IP + .dword FETCH + .dword UDOT + .dword DUP + .dword UDOT + .endif + ONLIT DO_TOKEN ; ( ... token xt ) + .dword CATCH ; ( ... xn ) + .if trace_fcode + ONLIT ']' + .dword EMIT + .dword CR + .endif + .dword QDUP + .dword _IF + .dword lp ; false ( -- ) go to loop + .dword DUP ; true, ( exc -- exc exc' ) save in $FCODE-END + .dword dFCODE_END ; ( ... exc exc' c-addr ) + .dword STORE ; ( ... exc ) + .dword DUP ; ( ... exc exc' ) + .dword _IF ; ( ... exc ) + .dword :+ + SLIT " FCode error " + .dword TYPE + .dword DUP ; ( ... exc exc' ) + .dword DOTD ; ( ... exc ) + SLIT "@ " + .dword TYPE + .dword dFCODE_IP ; ( ... exc addr ) + .dword FETCH ; ( ... exc addr2 ) + .dword UDOT ; ( ... exc ) +: ;.dword DOTS + .dword THROW ; ( exc -- ) and THROW +done: EXIT +exdword + +xdword FCEND + ENTER + ONLIT 1 + .dword dFCODE_END + .dword STORE + EXIT +exdword + +xdword VERSION1 + ENTER + .dword ONE ; spread + .dword ZERO ; offset (0 = 8, nonzero = 16) +set: .dword dFCODE_OFFSET + .dword STORE + .dword dFCODE_SPREAD + .dword STORE +drophdr: ONLIT 7 + .dword xFCODE_SKIP ; drop the header + EXIT +exdword + +xdword OFFSET16 + ENTER + .dword dFCODE_OFFSET + .dword ON + EXIT +exdword + +xdword START4 + ENTER + ONLIT 4 +set: .dword MINUSONE + JUMP VERSION1::set +exdword + +xdword START2 + ENTER + .dword TWO + JUMP START4::set +exdword + +xdword START1 + ENTER + .dword ONE + JUMP START4::set +exdword + +xdword START0 + ENTER + .dword ZERO + JUMP START4::set +exdword + +xdword B_LIT + ENTER + .dword xFCODE_FETCH_NUM32 +dolit: .dword _SMART + .dword interp + .dword LITERAL +interp: EXIT +exdword + +xdword B_TICK + ENTER + .dword xFCODE_FETCH_TOKEN + .dword GET_TOKEN + .dword DROP + JUMP B_LIT::dolit +exdword + +xdword B_QUOTE + ENTER + .dword xFCODE_FETCH_STR ; ( -- c-addr u ) get length of string + ;.dword DBGMEM + .dword TWODUP ; ( c-addr u -- c-addr u c-addr' u' ) + .dword _SMART + .dword interp + .dword SLITERAL ; ( ... c-addr u ) + JUMP done +interp: .dword dTMPSTR ; ( ... c-addr u c-addr2 u2 ) + .dword TWOSWAP ; ( ... c-addr2 u2 c-addr u ) +done: .dword FREE ; ( ... c-addr2 u2 ) | ( ... ) + ;.dword DBGMEM + EXIT +exdword + +; Defining stuff in FCode is kind of a pain because there is a preparation step +; consisting of NEW-TOKEN, NAMED-TOKEN, or EXTERNAL token that starts the definition +; followed by one of the words that defines the behavior of the definition + +xdword dMKENTRY + jsl _l2parm + jsl _lmkentry + LPUSHNEXT ; flags/XT +exdword + +xdword EXTERNAL_TOKEN + ENTER +doext: .dword xFCODE_FETCH_STR ; ( -- str len ) + .dword TWODUP ; ( str len -- str len str' len' ) + .dword TWOPtoR ; ( str len str' len' -- str len) ( R: str' len' ) + .dword xFCODE_FETCH_TOKEN ; ( str len -- str len fcode# ) + .dword NROT ; ( str len fcode# -- fcode# str len ) + .dword dMKENTRY ; ( fcode# str len -- fcode# xt ) + .dword TWORtoP ; ( fcode# xt -- fcode# xt str' len' ) + .dword FREE ; ( fcode# xt str' len' -- fcode# xt ) +settok: ONLIT 0 ; ( fcode# xt -- fcode# xt f ) + .dword ROT ; ( fcode# xt f -- xt f fcode# ) + .dword DUP ; ( ... xt f fcode# fcode# ) + .dword dFCODE_LAST ; ( ... xt f fcode# fcode# c-addr ) + .dword STORE ; ( ... xt f fcode# ) + .dword SET_TOKEN ; ( xt f fcode# -- ) + EXIT +exdword + +xdword NEW_TOKEN + ENTER + .dword xFCODE_FETCH_TOKEN ; ( -- fcode# ) + ONLIT $80 ; ( ... fcode# $80 ) name length is 0 for noname + .dword CCOMMA ; ( ... fcode# ) + .dword HERE ; ( ... fcode# xt ) XT/flags + ONLIT $00 ; ( ... fcode# xt $00 ) noname flags + .dword CCOMMA ; ( ... fcode# xt ) + JUMP EXTERNAL_TOKEN::settok +exdword + +xdword NAMED_TOKEN + ENTER + .dword dFCODE_DEBUG + .dword FETCH + .dword _IFFALSE + .dword EXTERNAL_TOKEN::doext + .dword xFCODE_FETCH_STR ; retrieve token name + .dword FREE ; immediately free it + .dword NEW_TOKEN ; and make headerless + EXIT +exdword + +xdword B_COLON + ENTER + .dword dCOLON ; compile ENTER + .dword dFCODE_LAST ; ( -- c-addr ) + .dword FETCH ; ( c-addr -- fcode# ) + .dword GET_TOKEN ; ( fcode# -- xt f ) + .dword DROP ; ( xt f -- xt ) + .dword DUP ; ( xt -- xt xt' ) + .dword rLINK ; ( xt xt' -- xt c-addr|0 ) + .dword QDUP ; ( xt c-addr|0 -- xt c-addr c-addr' | xt 0 ) + .dword _IF ; ( .. xt c-addr | xt ) + .dword noname + .dword dOLDHERE ; ( xt c-addr -- xt c-addr c-addr2 ) + .dword STORE ; ( xt c-addr c-addr2 -- xt ) + .dword DUP ; ( xt -- xt xt' ) + .dword SMUDGE ; ( xt xt' -- xt ) + .dword STATEC ; xt on stack for colon-sys + EXIT +noname: .dword STATEC ; xt on stack for colon-sys + EXIT +exdword + +xdword B_CONSTANT + jsl _l1parm + jml dVALUE::dovalue +exdword + +xdword B_FIELD + jsl _l1parm + jml dFIELD::dofield +exdword + +xdword DEST_ON_TOP + ENTER + ;.dword DOTS + .dword ZERO + .dword PtoR +b1: .dword DUP + .dword FETCH + ONLIT _CONTROL_MM + .dword EQUAL + .dword _IF + .dword e1b2 + .dword PtoR + JUMP b1 +e1b2: .dword RtoP + .dword DUP + .dword _IF + .dword e2 + .dword SWAP + JUMP e1b2 +e2: .dword DROP + ;.dword DOTS + EXIT +exdword + +; Branch FCode while interpreting +; ( fcode-offset -- ) +xdword IBRANCH + ENTER + .dword DUP + .dword ZEROLT + .dword _IF + .dword pos ; positive offset, just skip + .dword dFCODE_SPREAD ; negative offset, compute new IP + .dword FETCH + .dword UMULT + .dword dFCODE_IP + .dword FETCH + .dword PLUS + .dword dFCODE_IP + .dword STORE + EXIT +pos: .dword DECR + .dword dFCODE_OFFSET + .dword FETCH + .dword _IF ; offset size + .dword :+ ; 8, skip forward + .dword DECR ; decrement again +: .dword xFCODE_SKIP + EXIT +exdword + +; Maybe branch FCode +xdword BQBRANCH + ENTER + .dword xFCODE_FETCH_OFFSET + .dword _SMART + .dword interp + .dword ZEROLT ; is offset negative? + .dword _IF + .dword cpos ; no, positive offset + .dword UNTIL + EXIT +cpos: .dword IF + ;.dword DOTS + EXIT +interp: .dword SWAP ; move flag to front + .dword _IFFALSE + .dword nobr ; do nothing if true + .dword IBRANCH ; otherwise branch + EXIT +nobr: .dword DROP ; drop offset + EXIT +exdword + +xdword BBRANCH + ENTER + .dword xFCODE_FETCH_OFFSET + .dword _SMART + .dword interp + .dword ZEROLT + .dword _IF + .dword cpos + .dword AGAIN + EXIT +cpos: .dword dFCODE_IP + .dword FETCH + .dword xFCODE_FETCH_TOKEN ; peek next token + ONLIT $B2 ; B(>RESOLVE) + .dword EQUAL ; see if it's B(>RESOLVE) + .dword _IF + .dword ahead ; it's not, do ahead and fix IP + .dword DROP ; drop saved IP + .dword ELSE ; do ELSE + EXIT +ahead: .dword AHEAD + .dword dFCODE_IP + .dword STORE + EXIT +interp: .dword IBRANCH ; otherwise branch + EXIT +exdword + +xdword B_MARK + ENTER + .dword _SMART + .dword done ; interpreting + .dword BEGIN +done: EXIT +exdword + +xdword B_RESOLVE + ENTER + ;.dword DOTS + .dword _SMART + .dword done ; interpreting + .dword THEN +done: EXIT +exdword + +xdword B_CASE,F_IMMED|F_TEMPD + ENTER + .dword CASE + EXIT +exdword + +xdword B_ENDCASE + ENTER + .dword ENDCASE + EXIT +exdword + +xdword B_OF + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword OF + EXIT +exdword + +xdword B_ENDOF + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword ENDOF + EXIT +exdword + +xdword B_DO,F_IMMED|F_TEMPD + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword DO ; postpone DO + EXIT +exdword + +xdword B_QDO,F_IMMED|F_TEMPD + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword QDO + EXIT +exdword + +xdword B_LOOP + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword LOOP + EXIT +exdword + +xdword B_PLOOP + ENTER + .dword xFCODE_FETCH_OFFSET + .dword DROP + .dword PLOOP + EXIT +exdword + + +xdword B_LEAVE + ENTER + .dword _COMP_LIT + .dword LEAVE + EXIT +exdword + +xdword B_TO + ENTER + .dword xFCODE_FETCH_TOKEN + .dword GET_TOKEN + .dword DROP + JUMP TO::doto + EXIT +exdword + +xdword FCODE_REVISION + FCONSTANT $00030000 +exdword + diff --git a/asm/forth-dictionary.s b/asm/forth-dictionary.s new file mode 100644 index 0000000..5bbfe0b --- /dev/null +++ b/asm/forth-dictionary.s @@ -0,0 +1,6914 @@ + +; Forth Built-in Dictionary + +; Note that no primitive words should start with a JSL as the body-modifying words +; such as TO, DEFER!, etc. will assume that they can write to the cell immediately +; following the JSL. This would be bad if they are not supposed to do so. +; of course, this caution doesn't apply to words in ROM that can't be altered + +; comments starting with H: define help text to be used if I ever ship a help command + +dstart "forth" + +.if max_search_order > 0 +; ( u -- wid ) search order word list entry by number +hword WLNUM,"WL#" + ENTER + .dword dORDER + .dword SWAP + .dword DUP + ONLIT max_search_order + .dword ULT + .dword _IF + .dword bad + .dword INCR + .dword NAPLUS + EXIT +bad: ONLIT -49 + .dword THROW +eword + +; H: ( widn ... wid1 n -- ) set dictionary search order +dword SET_ORDER,"SET-ORDER" + ENTER + .dword DUP + .dword _IF + .dword empty + .dword DUP ; ( ... widn ... wid1 n n' ) + ONLIT 0 ; ( ... widn ... wid1 n n' 1 ) + .dword SLT ; ( ... widn ... wid1 n f ) + .dword _IF ; ( ... widn ... wid1 n ) + .dword dolist + .dword DROP ; ( n -- ) + .dword FORTH_WORDLIST ; ( -- wid ) + ONLIT 1 ; ( ... wid 1 ) +dolist: .dword DUP ; ( ... widn ... wid1 u u' ) + ONLIT max_search_order ; ( ... widn ... wid1 u u' u2 ) + .dword ULTE ; ( ... widn ... wid1 u f ) + .dword _IF ; ( ... widn ... wid1 u ) + .dword bad + .dword DUP ; ( ... widn ... wid1 u u' ) + .dword dORDER ; ( ... widn ... wid1 u u' c-addr ) + .dword STORE ; ( ... widn ... wid1 u ) + .dword DECR + ONLIT 0 ; ( ... widn ... wid1 u' 0 ) + .dword SWAP ; ( ... widn ... wid1 0 u' ) + .dword _DO ; ( ... widn ... wid1 ) + JUMP lpdone +lp: .dword IX ; ( ... widn ... wid1 u' ) + .dword WLNUM ; ( ... widn ... wid1 c-addr ) + .dword STORE + ONLIT -1 + .dword _PLOOP + .dword lp +lpdone: .dword UNLOOP + EXIT +bad: ONLIT -49 + .dword THROW +empty: .dword dORDER + .dword STORE + EXIT +eword + +.endif + +.if max_search_order > 0 +; H: ( -- wid ) return wordlist containing system words +dword FORTH_WORDLIST,"FORTH-WORDLIST" +.else +hword FORTH_WORDLIST,"FORTH-WORDLIST" +.endif + SYSVAR SV_FORTH_WL +eword + +; H: ( -- ) set the first wordlist in the search order to the system words +dword FORTH,"FORTH" +.if max_search_order > 0 + ENTER + .dword FORTH_WORDLIST + .dword TOP_OF_ORDER + EXIT +.else + ; no-op if no search-ordering allowed + NEXT +.endif +eword + +.if max_search_order > 0 +; H: ( -- wid ) return the wordlist for environmental queries +dword dENVQ_WL,"$ENV?-WL" +.else +hword dENVQ_WL,"$ENV?-WL" +.endif + SYSVAR SV_ENV_WL +eword + +; The prior was the absolute minimum search order that is possible, but we will +; not use it directly, "FORTH" will be the minimum. However this will be the root +; of all additional wordlists so that the system can be brought into a usable state +; via FORTH. + +; ( -- a-addr ) variable containing location of search order +hword ddORDER,"$$ORDER" + SYSVAR SV_dORDER +eword + +; ( -- a-addr ) location of search order stack +hword dORDER,"$ORDER" + ENTER + .dword ddORDER + .dword FETCH + EXIT +eword + +; ( -- a-addr ) variable containing current compiler wordlist +hword dCURRENT,"$CURRENT" + SYSVAR SV_CURRENT +eword + +.if max_search_order > 0 +; H: ( -- wid ) return first wordlist in search order +dword CONTEXT,"CONTEXT" +.else +hword CONTEXT,"CONTEXT" +.endif + ENTER +.if max_search_order > 0 + .dword dORDER + .dword FETCH + .dword QDUP + .dword _IF + .dword empty + .dword DECR + .dword WLNUM + .dword FETCH + EXIT +.endif +empty: .dword dCURRENT + .dword FETCH + EXIT +eword + +.if max_search_order > 0 +; H: ( -- wid ) get current compiler wordlist +dword GET_CURRENT,"GET-CURRENT" +.else +hword GET_CURRENT,"GET-CURRENT" +.endif + ENTER + .dword dCURRENT + .dword FETCH + EXIT +eword + +.if max_search_order > 0 +; H: ( -- widn ... wid1 u ) get dictionary search order +dword GET_ORDER,"GET-ORDER" + ENTER + .dword dORDER + .dword FETCH + ONLIT 0 + .dword _QDO + JUMP lpdone +lp: .dword IX + .dword WLNUM + .dword FETCH + ONLIT 1 + .dword _PLOOP + .dword lp +lpdone: .dword UNLOOP + .dword dORDER + .dword FETCH + EXIT +eword + +; ( wid -- ) set the first wordlist in the search order +hword TOP_OF_ORDER,"TOP-OF-ORDER" + ENTER + .dword PtoR + .dword GET_ORDER + .dword QDUP + .dword _IF + .dword default + .dword NIP + .dword RtoP + .dword SWAP + .dword SET_ORDER + EXIT +default: .dword RtoP + ONLIT 1 + .dword SET_ORDER + EXIT +eword + +; H: ( -- ) duplicate the first wordlist in the search order +dword ALSO,"ALSO" + ENTER + .dword GET_ORDER + .dword QDUP + .dword _IFFALSE + .dword :+ + .dword GET_CURRENT + .dword ONE +: .dword INCR + .dword OVER + .dword SWAP + .dword SET_ORDER + EXIT +eword + +; H: ( -- ) remove the first wordlist in the search order +dword PREVIOUS,"PREVIOUS" + ENTER + .dword GET_ORDER + .dword QDUP + .dword _IF + .dword noorder + .dword NIP + .dword DECR + .dword SET_ORDER + EXIT +noorder: ONLIT -50 + .dword THROW +eword + +; H: ( wid -- ) set the compiler wordlist +dword SET_CURRENT,"SET-CURRENT" + ENTER + .dword dCURRENT + .dword STORE + EXIT +eword + +; H: ( -- ) set the search order to contain only the system wordlist +dword ONLY,"ONLY" + ENTER + .dword FORTH_WORDLIST + ONLIT 1 + .dword SET_ORDER + EXIT +eword + +; H: ( -- ) set the search order to contain only the current top of the order +dword SEAL,"SEAL" + ENTER + .dword CONTEXT + .dword ONE + .dword SET_ORDER + EXIT +eword + +; H: ( wid -- c-addr u ) return the name of a wordlist, or ^address if no name +hword WL_NAME,"WL-NAME" + ENTER + .dword DUP + .dword CELLPLUS + .dword FETCH + .dword QDUP + .dword _IF + .dword noname + .dword NIP + .dword rNAME + EXIT +noname: JUMP rNAME_noname1 + EXIT +eword + +; H: ( -- ) display the current search order and compiler wordlist +dword ORDER,"ORDER" + ENTER + SLIT "Compiling to: " + .dword TYPE + .dword GET_CURRENT + .dword WL_NAME + .dword TYPE + .dword CR + SLIT "Search order:" + .dword TYPE + .dword CR + .dword GET_ORDER + ONLIT 0 + .dword _QDO + JUMP lpdone +lp: .dword WL_NAME + .dword TYPE + .dword CR + ONLIT 1 + .dword _PLOOP + .dword lp +lpdone: .dword UNLOOP + EXIT +eword + +; H: ( -- ) set the compiler wordlist to the first wordlist in the search order +dword DEFINITIONS,"DEFINITIONS" + ENTER + .dword CONTEXT + .dword SET_CURRENT + EXIT +eword +.endif + +; ( -- cell ) read literal cell from instruction stream, place it on the stack +hword _LIT,"_LIT" + jsr _fetch_ip_cell + PUSHNEXT +eword + +; ( -- word ) read literal word from instruction stream, place it on the stack +hword _WLIT,"_WLIT" + jsr _fetch_ip_word + tay + lda #$0000 + PUSHNEXT +eword + +; ( -- char ) read literal char from instruction stream, place it on the stack +hword _CLIT,"_CLIT" + jsr _fetch_ip_byte + tay + lda #$0000 + PUSHNEXT +eword + +; ( -- c-addr u ) skip string in instruction stream, place address and len on stack +; read cell-sized from instruction stream, place it on the stack +; place the address of the next cell on the stack +; skip bytes in the instruction stream +hword _SLIT,"_SLIT" + jsr _fetch_ip_cell + sty WR + sta WR+2 + jsr _pushay + ldy IP + lda IP+2 + iny + bne :+ + inc a +: jsr _pushay + jsr _swap + lda IP + clc + adc WR + sta IP + lda IP+2 + adc WR+2 + sta IP+2 + NEXT +eword + + +; ( -- ) Directly compile a cell literal from IP to [HERE] +; read next cell from instruction stream, compile it into the dictionary +hword _COMP_LIT,"_COMP_LIT" + jsr _fetch_ip_cell + jsr _ccellay + NEXT +eword + +; ( -- ) Directly compile a character literal from IP to [HERE] +; read char from instruction stream, compile it into the dictionary +hword _COMP_CLIT,"_COMP_LIT" + jsr _fetch_ip_byte + jsr _cbytea + NEXT +eword + +; ( -- ) System initialization +hword ddSYSINIT,"$$SYSINIT" + ENTER + .dword FORTH_WORDLIST ; make sure current wordlist is the Forth wordlist + .dword dCURRENT + .dword STORE + .dword HERE ; set up minimal search order stuff + .dword ddORDER + .dword STORE + ONLIT 0 ; for # of items in order + .dword COMMA +.if max_search_order > 0 + ONLIT max_search_order ; now allocate the storage for the search order + .dword CELLS + .dword ALLOT +.endif ; match_search_order + .dword dMEMTOP ; set $HIMEM to $MEMTOP for dynamic allocation + .dword FETCH + .dword dHIMEM + .dword STORE + ONLIT tib_size + .dword ALLOC ; TODO: catch exception + .dword dTIB + .dword STORE + NLIT NOOP ; set up STATUS defer. + SLIT "STATUS" + .dword dDEFER + .dword PROTECTED ; make sure it can't be FORGETted + .dword CR ; and say hello + SLIT "OF816 by M.G." + .dword TYPE + .dword CR + EXIT +eword + +; ( xt base -- ) execute xt with temporary base +hword TMPBASE,"TMPBASE" + ENTER + .dword BASE + .dword DUP + .dword FETCH + .dword PtoR + .dword STORE + .dword CATCH + .dword RtoP + .dword BASE + .dword STORE + .dword THROW + EXIT +eword + +; H: ( -- ) display version information +dword DOTVERSION,".VERSION" + ENTER + SLIT .concat("OF816 v",VERSION,"/") + .dword TYPE + ONLIT .time + ONLIT UDOT + ONLIT 16 + .dword TMPBASE + .if .strlen(PLATFORM) > 0 + SLIT .concat("for ", PLATFORM, ", CA65 ", .sprintf("%d.%d",.hibyte(.version),(.version & $F0)/$10)) + .else + SLIT ", CA65" + .endif + .dword TYPE + .dword CR + .if include_fcode + SLIT "FCode enabled" + .dword TYPE + .dword CR + .endif + EXIT +eword + +; H: ( -- ) reset the system +dword RESET_ALL,"RESET-ALL" + lda #SI_RESET_ALL + jsl _call_sysif + bcc :+ + jmp _throway +: NEXT +eword + +; H: ( -- ) restore system stack pointer and return to caller +dword BYE,"BYE" + lda SYS_RSTK + tcs + rtl +eword + +; ( n -- ) display exception message +; Display a message associated with exception # n. It first looks to see if there +; is a MESSAGE ( n -- n|0 ) word in the current search order. If there is, it calls it and +; if n2 is nonzero, assumes no message was displayed and proceeds, otherwise we are done. +hword _MESSAGE,"_MESSAGE" + ENTER + SLIT "MESSAGE" + .dword dFIND + .dword _IF + .dword notfound + .dword CATCH + .dword _IFFALSE + .dword exc + .dword QDUP + .dword _IFFALSE + .dword nomsg + EXIT +notfound: .dword TWODROP +nomsg: ONLIT -4 + .dword _IFEQUAL + .dword :+ + SLIT "Stack u/f" + JUMP dotype +: ONLIT -13 + .dword _IFEQUAL + .dword :+ + SLIT "Def not found" + JUMP dotype +: ONLIT -10 + .dword _IFEQUAL + .dword :+ + SLIT "Div by 0" + JUMP dotype +: SLIT "Exception #" + .dword TYPE + .dword DOTD + EXIT +exc: SLIT "Exc. in MESSAGE!" +dotype: .dword TYPE + .dword DROP + EXIT +eword + +; H: ( xt -- xi ... xj n ) call xt, trap exception and return in n +; catch return stack frame is: +; IP (4), old RSTK_SAVE (2), data SP (2, first out) +dword CATCH,"CATCH" + jsr _popwr ; remove xt for now, throw exception if none given + inc CATCHFLAG + lda IP+2 ; put catch frame on stack + pha ; starting with IP + lda IP + pha + lda RSTK_SAVE ; old saved return stack pointer + pha + phx ; data stack pointer + tsc + sta RSTK_SAVE ; save return stack for later restoration + ldy WR + lda WR+2 + jsr _pushay ; push xt back on stack + ENTER + .dword EXECUTE ; execute framed xt + CODE + ; no exception if we got here + lda #$0000 + sta WR ; exit code will be zero + sta WR+2 + pla ; drop old data SP +fixup: pla ; get old RSTK_SAVE + sta RSTK_SAVE + pla + sta IP ; restore previous IP (after catch) + pla + sta IP+2 + dec CATCHFLAG + ldy WR + lda WR+2 + PUSHNEXT +eword + +; H: ( n -- ) throw exception n if n <> 0 +dword THROW,"THROW" + jsr _popay ; get exception # from stack +throway: .if trace + wdm $90 + wdm $8f + .endif + cmp #$0000 ; is it zero? + bne :+ + cpy #$0000 + bne :+ + NEXT ; if zero, do nothing +: sty WR ; if not zero, save it + sta WR+2 + lda CATCHFLAG ; CATCH active? + beq uncaught ; nope, go handle it + lda RSTK_SAVE ; restore stack pointer to catch frame + tcs + plx ; restore data stack pointer + bra CATCH::fixup ; "return" from CATCH +uncaught: lda #$FFFF ; is negative? + cmp WR+2 + bne :+ ; nope, don't check for specifics + lda WR + cmp #.loword(-1) ; ABORT + beq abort + cmp #.loword(-2) ; ABORT" + beq abort +: jsr _stackroom ; make room on data stack if needed + ldy WR + lda WR+2 + jsr _pushay ; push exception # back on stack + ENTER ; short routine to display error message + .dword SPACE + .dword _MESSAGE + CODE + jmp __doquit ; and restart with QUIT +abort: ldx STK_TOP ; empty data stack per standard for ABORT + jmp __doquit ; and restart with QUIT +eword +_throway = THROW::throway + +; ( -- f ) return true if a CATCH is active +hword CATCHQ,"CATCH?" + ldy CATCHFLAG + lda #$00 + PUSHNEXT +eword + +; ( f c-addr u -- ) word compiled or executed by ABORT" +; if f is true display c-addr u and execute -2 THROW, otherwise continue execution +hword _ABORTQ,"_ABORT'" + ENTER + .dword ROT + .dword _IF + .dword noabort + .dword CATCHQ + .dword _IF + .dword dotype + .dword TWODROP + .dword _SKIP +dotype: .dword TYPE + .dword CLEAR + ONLIT -2 + .dword THROW +noabort: .dword TWODROP + EXIT +eword + +; H: ( f -- ) parse string ending in " from input stream, execute -2 THROW if f is true +dwordq ABORTQ,"ABORT'",F_IMMED + ENTER + .dword SQ + .dword _SMART + .dword interp + .dword _COMP_LIT +interp: .dword _ABORTQ + EXIT +eword + +; H: ( -- ) execute -1 THROW +dword ABORT,"ABORT" + ENTER + ONLIT -1 + .dword THROW + EXIT +eword + +; H: ( -- u ) u = address of the CPU direct page +dword dDIRECT,"$DIRECT" + tdc + tay + lda #$00 + PUSHNEXT +eword + +; H: ( -- u ) u = top of usable data space +dword dMEMTOP,"$MEMTOP" + ENTER + .dword dDIRECT + ONLIT MEM_TOP + .dword PLUS + EXIT +eword + +; H: ( -- u ) u = unused data space accounting for PAD and dynamic allocations +dword UNUSED,"UNUSED" + ENTER + .dword dHIMEM + .dword FETCH + .dword HERE + .dword MINUS + ONLIT 16 + .dword MINUS + ONLIT word_buf_size + .dword MINUS +.if pad_size > 0 + ONLIT pad_size + .dword MINUS +.endif + EXIT +eword + +; H: ( -- ) do nothing +dword NOOP,"NOOP" + NEXT +eword + +; H: ( -- u ) u = size of char in bytes +dword SCHAR,"/C" + FCONSTANT 1 +eword + +; H: ( -- u ) u = size of word in bytes +dword SWORD,"/W" + FCONSTANT 2 +eword + +; H: ( -- u ) u = size of long in bytes +dword SLONG,"/L" + FCONSTANT 4 +eword + +; H: ( -- u ) u = size of cell in bytes +dword SCELL,"/N" + FCONSTANT 4 +eword + +; H: ( u1 n -- u2 ) u2 = u1 + n * size of char in bytes +dword CAPLUS,"CA+" + ENTER + .dword SCHAR +domath: .dword UMULT + .dword PLUS + EXIT +eword + +; H: ( u1 n -- u2 ) u2 = u1 + n * size of word in bytes +dword WAPLUS,"WA+" + ENTER + .dword SWORD + JUMP CAPLUS::domath +eword + +; H: ( u1 n -- u2 ) u2 = u1 + n * size of long in bytes +dword LAPLUS,"LA+" + ENTER + .dword SLONG + JUMP CAPLUS::domath +eword + +; H: ( u1 n -- u2 ) u2 = u1 + n * size of cell in bytes +dword NAPLUS,"NA+" + ENTER + .dword SCELL + JUMP CAPLUS::domath +eword + +; H: ( u1 -- u2 ) u2 = u1 + size of char in bytes +dword CHARPLUS,"CHAR+" + ENTER + .dword SCHAR + .dword PLUS + EXIT +eword + +; H: ( u1 -- u2 ) u2 = u1 + size of cell in bytes +dword CELLPLUS,"CELL+" + ENTER + .dword SCELL + .dword PLUS + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of char +dword CHARS,"CHARS" + ENTER + .dword SCHAR + .dword UMULT + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of cell +dword CELLS,"CELLS" + ENTER + .dword SCELL + .dword UMULT + EXIT +eword + +; H: ( u1 -- u2 ) u2 = next aligned address after u1 +dword ALIGNED,"ALIGNED" + NEXT +eword + +; H: ( n1 -- n2 ) n2 = n1 + size of char +dword CAINCR,"CA1+" + jmp CHARPLUS::code +eword + +; H: ( n1 -- n2 ) n2 = n1 + size of word +dword WAINCR,"WA1+" + ENTER + .dword SWORD + .dword PLUS + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 + size of long +dword LAINCR,"LA1+" + ENTER + .dword SLONG + .dword PLUS + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 + size of cell +dword NAINCR,"NA1+" + jmp CELLPLUS::code +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of char +dword SCHARMULT,"/C*" + jmp CHARS::code +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of word +dword SWORDMULT,"/W*" + ENTER + .dword SWORD + .dword UMULT + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of long +dword SLONGMULT,"/L*" + ENTER + .dword SLONG + .dword UMULT + EXIT +eword + +; H: ( n1 -- n2 ) n2 = n1 * size of cell +dword SCELLMULT,"/N*" + jmp CELLS::code +eword + +; H: ( u -- u1 ... u4 ) u1 ... u4 = bytes of u +dword LBSPLIT,"LBSPLIT" + jsr _1parm + lda STACKBASE+0,x + ldy STACKBASE+2,x + pha + and #$FF + sta STACKBASE+0,x + stz STACKBASE+2,x + pla + xba + and #$FF + jsr _pusha + tya + and #$FF + jsr _pusha + tya + xba + and #$FF + ldy #$00 + PUSHNEXT +eword + +; H: ( u -- u1 ... u2 ) u1 ... u2 = words of u +dword LWSPLIT,"LWSPLIT" + jsr _1parm + ldy STACKBASE+2,x + stz STACKBASE+2,x + lda #$0000 + PUSHNEXT +eword + +; H: ( u -- u1 .. u2 ) u1 .. u2 = bytes of word u +dword WBSPLIT,"WBSPLIT" + jsr _1parm + stz STACKBASE+2,x + lda STACKBASE+0,x + pha + and #$FF + sta STACKBASE+0,x + pla + xba + and #$FF + tay + lda #$00 + PUSHNEXT +eword + +; H: ( b.l b2 b3 b.h -- q ) join bytes into quad +dword BLJOIN,"BLJOIN" + jsr _4parm + lda STACKBASE+12,x + and #$FF + sta STACKBASE+12,x + lda STACKBASE+8,x + and #$FF + xba + ora STACKBASE+12,x + sta STACKBASE+12,x + lda STACKBASE+4,x + and #$FF + sta STACKBASE+14,x + lda STACKBASE+0,x + and #$FF + xba + ora STACKBASE+14,x + sta STACKBASE+14,x +_3drop: inx + inx + inx + inx +_2drop: inx + inx + inx + inx +_1drop: inx + inx + inx + inx + NEXT +eword + +; H: ( b.l b.h -- w ) join bytes into word +dword BWJOIN,"BWJOIN" + jsr _2parm + stz STACKBASE+6,x + lda STACKBASE+4,x + and #$FF + sta STACKBASE+4,x + lda STACKBASE+0,x + and #$FF + xba + ora STACKBASE+4,x + sta STACKBASE+4,x + bra BLJOIN::_1drop +eword + +; H: ( w.l w.h -- q ) join words into quad +dword WLJOIN,"WLJOIN" + jsr _2parm + lda STACKBASE+0,x + sta STACKBASE+6,x + bra BLJOIN::_1drop +eword + +; H: ( w -- w' ) flip the byte order of word +dword WBFLIP,"WBFLIP" + jsr _1parm + lda STACKBASE+0,x + xba + sta STACKBASE+0,x + lda STACKBASE+2,x + xba + sta STACKBASE+2,x + NEXT +eword + +; H: ( q -- q' ) flip the byte order of quad +dword LBFLIP,"LBFLIP" + jsr _1parm + ldy STACKBASE+0,x + lda STACKBASE+2,x + xba + sta STACKBASE+0,x + tya + xba + sta STACKBASE+2,x + NEXT +eword + +; H: ( q -- q ) flip the word order of quad +dword LWFLIP,"LWFLIP" + jsr _1parm + ldy STACKBASE+0,x + lda STACKBASE+2,x + sta STACKBASE+0,x + sty STACKBASE+2,x + NEXT +eword + +; ( word -- sign-extended-long ) +dword WSX,"WSX" + jsr _1parm + ldy #$0000 + lda STACKBASE+0,x + and #$8000 + beq :+ + dey +: sty STACKBASE+2,x + NEXT +eword + +; ( byte -- sign-extended-long ) +dword BSX,"BSX" + jsr _1parm + ldy #$0000 + lda STACKBASE+0,x + and #$80 + beq :+ + dey +: sty STACKBASE+2,x + tya + and #$FF00 + ora STACKBASE+0,x + sta STACKBASE+0,x + NEXT +eword + +; ( -- c-addr ) +hword dHIMEM,"$HIMEM" + SYSVAR SV_HIMEM +eword + +; H: ( u -- c-addr ) allocate memory from heap +dword ALLOC,"ALLOC-MEM" + jsr _popxr ; size into XR + jsr _alloc + bcs :+ + ldy #.loword(-59) + lda #.hiword(-59) + jmp _throway +: PUSHNEXT +eword + +; H: ( c-addr u -- ) release memory to heap +dword FREE,"FREE-MEM" + jsr _stackincr ; we should really check this (len) + jsr _popwr + jsr _free + bcs :+ + ldy #.loword(-60) + lda #.hiword(-60) + jmp _throway +: NEXT +eword + +; H: ( -- ) display heap and temporary string information +dword DBGMEM,"DEBUG-MEM" + ENTER + .dword CR + SLIT "$CSBUF:" + .dword TYPE + .dword dCSBUF + .dword FETCH + .dword UDOT + SLIT "$SBUF0:" + .dword TYPE + .dword dSBUF0 + .dword FETCH + .dword UDOT + SLIT "$SBUF1:" + .dword TYPE + .dword dSBUF1 + .dword FETCH + .dword UDOT + .dword dHIMEM ; ( -- $himem ) +loop: .dword CR + .dword FETCH ; ( $himem -- u ) + .dword DUP ; ( u -- u1 u2 ) + .dword dMEMTOP ; ( u1 u2 -- u1 u2 $memtop ) + .dword FETCH ; ( u1 u2 $memtop -- u1 u2 u3 ) + .dword EQUAL ; ( u1 u2 u3 -- u1 f ) + .dword _IFFALSE ; ( u1 f -- u1 ) + .dword eom + .dword DUP + ONLIT HDR_SIZE + .dword PLUS + .dword UDOT ; output address + .dword DUP ; ( u1 -- u1 u2 ) + .dword DUP ; ( ... -- u1 u2 u3 ) + .dword FETCH ; ( u1 u2 u3 -- u1 u2 u3' ) + .dword SWAP ; ( u1 u2 u3' -- u1 u3' u2 ) + .dword MINUS ; ( u1 u2 u3' -- u1 u4 ) + ONLIT HDR_SIZE ; ( u1 u4 -- u1 u4 u5 ) + .dword MINUS ; ( u1 u4 u5 -- u1 u6 ) + .dword UDOT ; ( u1 u6 -- u1 ) output size + .dword DUP + ONLIT 4 + .dword PLUS + .dword WFETCH + ONLIT $8000 + .dword LAND + .dword _IF + .dword free + SLIT "used " + JUMP :+ +free: SLIT "free " +: .dword TYPE + ONLIT '@' + .dword EMIT + .dword DUP + .dword UDOT ; write header address + ONLIT '>' + .dword EMIT + .dword DUP + .dword FETCH + .dword UDOT + JUMP loop +eom: .dword UDOT + SLIT "$MEMTOP" + .dword TYPE + .dword CR + EXIT +eword + +; H: ( -- c-addr ) STATE variable, zero if interpreting +dword STATE,"STATE" + SYSVAR SV_STATE +eword + +; ( -- u ) variable containing depth of control-flow stack +hword dCSDEPTH,"$CSDEPTH" + SYSVAR SV_dCSDEPTH ; Control-flow stack depth for temporary definitions +eword + +; ( -- c-addr ) variable to store HERE during temporary definition creation +hword dSAVEHERE,"$SAVEHERE" + SYSVAR SV_dSAVEHERE ; saved HERE for temporary definitions +eword + +; ( -- c-addr ) variable pointing to memory allocated for temporary definition +hword dTMPDEF,"$>TMPDEF" + SYSVAR SV_pTMPDEF ; pointer to memory allocated for temp def +eword + +; H: ( -- ) enter interpretation state +dword STATEI,"[",F_IMMED|F_CONLY + ENTER + .dword STATE + .dword OFF + EXIT +eword + +; H: ( -- ) enter compilation state +; immediacy called out in IEEE 1275-1994 +dword STATEC,"]",F_IMMED + ENTER + .dword STATE + .dword ON + EXIT +eword + +; H: ( -- c-addr ) system BASE varaible +dword BASE,"BASE" + SYSVAR SV_BASE +eword + +; H: ( ... u -- ... ) call system interface function u +dword dSYSIF,"$SYSIF" + jsr _popay + tya + jsl _call_sysif + bcc :+ + jmp _throway +: NEXT +eword + +; Raw function needed by line editor +.proc _emit +do_emit: lda #SI_EMIT + jsl _call_sysif + bcc :+ + jmp _throway +: rts +.endproc + +; H: ( char -- ) output char +dword EMIT,"EMIT" + jsr _peekay + tya + and #$FF + cmp #' ' + bcc do_emit ; don't count control chars + ldy #SV_NOUT + lda [SYSVARS],y ; increment #OUT + inc a + sta [SYSVARS],y + bne do_emit + iny + iny + lda [SYSVARS],y + inc a + sta [SYSVARS],y +do_emit: jsr _emit + NEXT +eword + +; H: ( c-addr u -- ) output string +dword TYPE,"TYPE" + jsr _popxr + jsr _popwr + ldy #.loword(do_emit-1) + lda #.hiword(do_emit-1) + jsr _str_op_ay + NEXT +do_emit: jsr _pusha + ENTER + .dword EMIT + CODE + clc + rtl +eword + +; H: ( -- f ) if #LINE >= 20, prompt user to continue and return false if they want to +dword EXITQ,"EXIT?" + ENTER + .dword NLINE + .dword FETCH + ONLIT 20 ; TODO: replace with variable + .dword UGTE + .dword _IF + .dword nopage + ONLIT 0 + .dword NLINE + .dword STORE + SLIT "more? (Y/n)" + .dword TYPE + .dword KEY + .dword CR + .dword LCC + ONLIT 'n' + .dword EQUAL + EXIT +nopage: .dword FALSE + EXIT +eword + +; H: ( -- c-addr ) variable containing the number of lines output +dword NLINE,"#LINE" + SYSVAR SV_NLINE +eword + +; H: ( -- c-addr ) variable containing the number of chars output on the current line +dword NOUT,"#OUT" + SYSVAR SV_NOUT +eword + +; H: ( -- c-addr ) variable containing offset to the current parsing area of input buffer +dword PIN,">IN" + SYSVAR SV_PIN +eword + +; H: ( -- c-addr ) variable containing number of chars in the current input buffer +dword NIN,"#IN" + SYSVAR SV_NIN +eword + +; H: ( xt -- ) execute xt, regardless of its flags +dword EXECUTE,"EXECUTE" + jsr _popay + RUN +eword + +; ( -- ) read a cell from the instruction stream, set the next IP to it +hword _JUMP,"_JUMP" + jsr _fetch_ip_cell + jsr _decay +go: sty IP + sta IP+2 + NEXT +eword + +; ( -- ) read and discard a cell from the instruction stream +hword _SKIP,"_SKIP" + jsr _fetch_ip_cell + NEXT +eword + +; ( -- ) read a cell from the instruction stream; if interpretation state set IP to it +hword _SMART,"_SMART" + .if 1 ; native + ldy #SV_STATE + lda [SYSVARS],y + bne _SKIP::code + iny + iny + lda [SYSVARS],y + bne _SKIP::code + beq _JUMP::code + .else ; mixed + ENTER + .dword STATE + .dword FETCH + CODE + jsr _popay + sty WR + ora WR + beq _JUMP::code + bne _SKIP::code + .endif +eword + +; ( -- ) read and discard two cells from the instruction stream +hword _SKIP2,"_SKIP2" + jsr _fetch_ip_cell + bra _SKIP::code +eword + +; H: ( n -- ) compile cell n into the dictionary +dword COMMA,"," + jsr _popay + jsr _ccellay + NEXT +eword + +; H: ( xt -- ) compile xt into the dictionary +; immediacy called out in IEEE 1275-1994 +dword COMPILECOMMA,"COMPILE,",F_IMMED + bra COMMA::code +eword + +; H: ( n -- ) compile numeric literal n into dictionary, leave n on stack at execution +dword LITERAL,"LITERAL",F_IMMED + jsr _1parm + .if no_fast_lits + ldy #.loword(_LIT) + lda #.hiword(_LIT) + jsr _ccellay ; compile _LIT + bra COMMA::code ; compile actual number + .else + lda STACKBASE+2,x + ora #$0000 + beq COMMA::code ; compile fast literal + ldy #.loword(_LIT) + lda #.hiword(_LIT) + jsr _ccellay ; compile _LIT + bra COMMA::code ; compile actual number + .endif +eword + +; H: ( char -- ) compile char into dictionary +dword CCOMMA,"C," + jsr _popay + tya + jsr _cbytea + NEXT +eword + +; H: ( word -- ) compile word into dictionary +dword WCOMMA,"W," + jsr _popay + tya + jsr _cworda + NEXT +eword + +; H: ( q -- ) compile quad into the dictionary +dword LCOMMA,"L," + bra COMMA::code +eword + +; H: ( u -- u ) align u (no-op in this implementation) +dword ALIGN,"ALIGN" + NEXT +eword + +; H: ( n -- ) allocate n bytes in the dictionary +dword ALLOT,"ALLOT" + jsr _popay + pha + tya + clc + adc DHERE + sta DHERE + pla + adc DHERE+2 + sta DHERE+2 + NEXT +eword + +; H: ( c-addr -- n ) fetch cell from c-addr +dword FETCH,"@" + jsr _popwr +fetch2: jsr _wrfetchind + PUSHNEXT +eword + +; H: ( c-addr -- n ) fetch cell from c-addr +dword LFETCH,"L@" + bra FETCH::code +eword + +.if unaligned_words +; H: ( c-addr -- n ) fetch cell from c-addr +dword LFECTCHU,"UNALIGNED-L@" + bra LFETCH::code +eword +.endif + +; H: ( c-addr -- n1 n2 ) fetch two consecutive cells from c-addr +dword TWOFETCH,"2@" + jsr _popwr + jsr _wrfetchind + jsr _pushay + jsr _wrplus4 + bra FETCH::fetch2 +eword + +; H: ( c-addr -- char ) fetch char from c-addr +dword CFETCH,"C@" + jsr _popwr + ldy #$00 + lda [WR],y + and #$00FF + jsr _pusha + NEXT +eword + +; H: ( c-addr -- word ) fetch word from c-addr +dword WFETCH,"W@" + jsr _popwr + ldy #$00 + lda [WR],y + jsr _pusha + NEXT +eword + +; H: ( c-addr -- n ) fetch sign-extended word from c-addr +dword WFETCHS,"R" + jsr _popay + pha + phy + NEXT +eword + +; H: ( n1 n2 -- ) (R: -- n1 n2 ) +; must be primitive +dword TWOPtoR,"2>R" + jsr _swap + jsr _popay + pha + phy + bra PtoR::code +eword + +; H: ( x1 ... xn n -- n ) ( R: x1 ... xn -- ) +; must be primitive +dword NPtoR,"N>R" + jsr _popay + sty YR + sty YR+2 + cpy #$00 + beq done + : jsr _popay + pha + phy + dec YR + bne :- +done: lda #$00 + ldy YR+2 + PUSHNEXT +eword + +; H: ( R: n -- ) ( -- n ) +; must be primitive +dword RtoP,"R>" + ply + pla + PUSHNEXT +eword + +; H: ( R: n1 n2 -- ) ( -- n1 n2 ) +; must be primitive +dword TWORtoP,"2R>" + ply + pla + jsr _pushay + ply + pla + jsr _pushay + jsr _swap + NEXT +eword + +; H: ( R: x1 ... xn -- ) ( n -- x1 ... xn n ) +dword NRtoP,"NR>" + jsr _popay + sty YR + sty YR+2 + cpy #$00 + beq done +: ply + pla + jsr _pushay + dec YR + bne :- +done: lda #$00 + ldy YR+2 + PUSHNEXT +eword + +; H: ( R: n -- n ) ( -- n ) +dword RCOPY,"R@" + lda 1,S + tay + lda 3,S + PUSHNEXT +eword + +; H: ( n -- n ) ( R: -- n ) +dword COPYR,">R@" + jsr _peekay + pha + phy + NEXT +eword + +; H: ( R: n1 n2 -- n1 n2 ) ( -- n1 n2 ) +dword TWORCOPY,"2R@" + lda 5,S + tay + lda 7,S + jsr _pushay + bra RCOPY::code +eword + +; H: ( R: n -- ) +dword RDROP,"RDROP" + pla + pla + NEXT +eword + +; H: ( R: n -- n' ) n' = n + 1 +; increment item on return stack +dword RINCR,"R+1" + lda 1,s + inc a + sta 1,s + bne :+ + lda 3,s + inc a + sta 3,s +: NEXT +eword + +; H: ( n1 -- n2 ) n2 = n1th cell in return stack +hword RPICK,"RPICK" + jsr _popwr + tya + asl + asl + sta WR + tsc + sec ; +1 + adc WR + sta WR + stz WR+2 + ldy #$02 + lda [WR],y + pha + dey + dey + lda [WR],y + tay + pla + NEXT +eword + +; ( -- n ) n = cell-extended 24-bit address +; pluck the machine return address underneath the Forth return address +; on the return stack and place it on the data stack. Used by DOES> +hword RPLUCKADDR,"RPLUCKADDR" + ply ; save top of stack address + sty WR + pla + sta WR+2 + sep #SHORT_A + .a8 + ply ; pull desired address + pla + rep #SHORT_A + .a16 + and #$00FF + jsr _pushay + lda WR+2 ; put back top of stack + pha + ldy WR + phy + NEXT +eword + +; H: ( n1 n2 -- n2 n1 ) +dword SWAP,"SWAP" + jsr _swap + NEXT +eword + +; H: ( n1 -- ) +dword DROP,"DROP" + jsr _stackincr + NEXT +eword + +; H: ( n1 n2 -- ) +dword TWODROP,"2DROP" + jsr _stackincr + jsr _stackincr + NEXT +eword + +; H: ( n1 n2 n3 -- ) +dword THREEDROP,"3DROP" + jsr _stackincr + jsr _stackincr + jsr _stackincr + NEXT +eword + +; H: ( n1 ... nx -- ) empty stack +dword CLEAR,"CLEAR" + ldx STK_TOP + NEXT +eword + +; H: ( n1 ... nx -- n1 ... nx x ) +dword DEPTH,"DEPTH" + stx WR + lda STK_TOP + sec + sbc WR + lsr + lsr + tay + lda #$0000 + PUSHNEXT +eword + +; H: ( n1 n2 -- n1 n2 n3 ) n3 = n1 +dword OVER,"OVER" + jsr _over + NEXT +eword + +; H: ( x1 ... xn u -- x1 ... xn x(n-u) ) +dword PICK,"PICK" + jsr _2parm + lda STACKBASE+0,x + asl + asl + sta WR + txa + clc + adc WR + phx + tax + ldy STACKBASE+4,x + lda STACKBASE+6,x + plx + sty STACKBASE+0,x + sta STACKBASE+2,x + NEXT +eword + +; H: ( -- ) display stack contents +dword DOTS,".S" + ENTER + ONLIT '{' + .dword EMIT + .dword SPACE + .dword DEPTH + .dword DUP + .dword DOT + ONLIT ':' + .dword EMIT + .dword SPACE + .dword DUP + .dword _IF + .dword done +lp: .dword DECR + .dword DUP + .dword PtoR + .dword PICK + .dword DOT + .dword RtoP + .dword DUP + .dword _IFFALSE + .dword lp +done: .dword DROP + ONLIT '}' + .dword EMIT + EXIT +eword + +; H: ( n1 n2 -- n2 ) +dword NIP,"NIP" + jsr _2parm + lda STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+2,x + sta STACKBASE+6,x + inx + inx + inx + inx + NEXT +eword + +; H: ( n1 n2 -- n3 n1 n2 ) n3 = n2 +dword TUCK,"TUCK" + ENTER + .dword SWAP + .dword OVER + EXIT +eword + +; H: ( n1 n2 n3 -- n3 ) +dword TWONIP,"2NIP" + ENTER + .dword PtoR + .dword TWODROP + .dword RtoP + EXIT +eword + +; H: ( n1 n2 -- n1 n2 n3 n4 ) n3 = n1, n4 = n2 +dword TWODUP,"2DUP" + jsr _over + jsr _over + NEXT +eword + +; H: ( n1 n2 n3 -- n1 n2 n3 n4 n5 n6 ) n4 = n1, n5 = n2, n6 = n3 +dword THREEDUP,"3DUP" + ENTER + ONLIT 3 + .dword PICK + ONLIT 3 + .dword PICK + ONLIT 3 + .dword PICK + EXIT +eword + +.proc _rot + ldy STACKBASE+10,x + lda STACKBASE+6,x + sta STACKBASE+10,x + lda STACKBASE+2,x + sta STACKBASE+6,x + sty STACKBASE+2,x + ldy STACKBASE+8,x + lda STACKBASE+4,x + sta STACKBASE+8,x + lda STACKBASE+0,x + sta STACKBASE+4,x + sty STACKBASE+0,x + rts +.endproc + +; H: ( n1 n2 n3 -- n2 n3 n1 ) +dword ROT,"ROT" + .if 1 ; native + jsr _3parm + jsr _rot + NEXT + .else ; secondary + ENTER + .dword PtoR + .dword SWAP + .dword RtoP + .dword SWAP + EXIT + .endif +eword + +; H: ( n1 n2 n3 -- n3 n1 n2 ) +dword NROT,"-ROT" + .if 1 ; native + jsr _3parm + ldy STACKBASE+2,x + lda STACKBASE+6,x + sta STACKBASE+2,x + lda STACKBASE+10,x + sta STACKBASE+6,x + sty STACKBASE+10,x + ldy STACKBASE+0,x + lda STACKBASE+4,x + sta STACKBASE+0,x + lda STACKBASE+8,x + sta STACKBASE+4,x + sty STACKBASE+8,x + NEXT + .else ; secondary + ENTER + .dword ROT + .dword ROT + EXIT + .endif +eword + +; H: ( xu ... x0 u -- xu-1 .. x0 xu ) +dword ROLL,"ROLL" + jsr _popxr ; put roll depth into XR + lda XR ; number of items - 1 that we are moving + beq done ; if none, GTFO + asl ; to see if enough room on stack + asl + sta XR+2 ; number of cells we are moving + txa + adc XR+2 + cmp STK_TOP + bcc :+ + jmp _stku_err +: stx WR ; save SP + tax ; change SP to xu + lda STACKBASE+2,x ; save xu + pha + lda STACKBASE+0,x + pha +lp: dex ; move to next-toward-top entry + dex + dex + dex + lda STACKBASE+2,x ; copy this entry to the one below + sta STACKBASE+6,x + lda STACKBASE+0,x + sta STACKBASE+4,x + cpx WR ; are we done? + beq :+ + bcs lp +: pla ; finally put xu on top + sta STACKBASE+0,x + pla + sta STACKBASE+2,x +done: NEXT +eword + +; H: ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) +dword TWOSWAP,"2SWAP" + ENTER + .dword PtoR + .dword NROT + .dword RtoP + .dword NROT + EXIT +eword + +; H: ( x1 x2 x3 x4 -- x1 x2 x3 x4 x5 x6 ) x5 = x1, x6 = x2 +dword TWOOVER,"2OVER" + ENTER + .dword TWOPtoR + .dword TWODUP + .dword TWORtoP + .dword TWOSWAP + EXIT +eword + +; H: ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) +dword TWOROT,"2ROT" + ENTER + .dword TWOPtoR + .dword TWOSWAP + .dword TWORtoP + .dword TWOSWAP + EXIT +eword + +; H: ( c-addr -- ) store all zero bits to cell at c-addr +dword OFF,"OFF" + jsr _popwr + lda #$0000 +onoff: tay + jsr _wrstoreind + NEXT +eword + +; H: ( c-addr -- ) store all one bits to cell at c-addr +dword ON,"ON" + jsr _popwr + lda #$FFFF + bra OFF::onoff +eword + +; H: ( -- false ) false = all zero bits +dword FALSE,"FALSE" + lda #$0000 + tay + PUSHNEXT +eword + +; H: ( -- true ) true = all one bits +dword TRUE,"TRUE" + lda #$FFFF + tay + PUSHNEXT +eword + +; small assembly routine common to zero comparisons +.proc _zcmpcom + jsr _1parm + ldy #$0000 + lda STACKBASE+2,x + rts +.endproc + +; H: ( n -- f ) f = true if x is zero, false if not +dword ZEROQ,"0=" + jsr _zcmpcom + ora STACKBASE+0,x + bne :+ + dey +st: jmp _cmpstore +eword +_cmpstore2 = ZEROQ::st + +; H: ( n -- f ) f = false if x is zero, true if not +dword ZERONEQ,"0<>" + jsr _zcmpcom + ora STACKBASE+0,x + beq _cmpstore2 + dey +: bra _cmpstore2 +eword + +; H: ( n -- f ) f = true if x > 0, false if not +dword ZEROGT,"0>" + jsr _zcmpcom + bmi _cmpstore2 + ora STACKBASE+0,x + beq _cmpstore2 + dey + bra _cmpstore2 +eword + +; H: ( n -- f ) f = true if x >= 0, false if not +dword ZEROGTE,"0>=" + jsr _zcmpcom + bmi _cmpstore2 + ora STACKBASE+0,x + bne _cmpstore2 + dey + bra _cmpstore2 +eword + +; H: ( n -- f ) f = true if x < 0, false if not +dword ZEROLT,"0<" + jsr _zcmpcom + bpl _cmpstore + dey + bra _cmpstore +eword + +; H: ( n -- f ) f = true if x <= 0, false if not +dword ZEROLTE,"0<=" + jsr _zcmpcom + bmi :+ + ora STACKBASE+0,x + bne _cmpstore +: dey + bra _cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 = n2, false if not +dword EQUAL,"=" + jsr _ucmpcom + bne _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 <> n2, false if not +dword NOTEQUAL,"<>" + jsr _ucmpcom + beq _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( u1 u2 -- f ) f = true if u1 < u2, false if not +dword ULT,"U<" + jsr _ucmpcom + bcs _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( u1 u2 -- f ) f = true if u1 <= u2, false if not +dword ULTE,"U<=" + jsr _ucmpcom + beq :+ + bcs _2cmpstore +: dey + bra _2cmpstore +eword + +; more comparison helper routines +.proc _2cmpstore + inx + inx + inx + inx + ; fall-through +.endproc + +.proc _cmpstore + sty STACKBASE+0,x + sty STACKBASE+2,x + NEXT +.endproc + +; H: ( u1 u2 -- f ) f = true if u1 > u2, false if not +dword UGT,"U>" + jsr _ucmpcom + beq _2cmpstore + bcc _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( u1 u2 -- f ) f = true if u1 >= u2, false if not +dword UGTE,"U>=" + jsr _ucmpcom + bcc _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 < n2, false if not +dword SLT,"<" + jsr _scmpcom + bcs _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 <= n2, false if not +dword SLTE,"<=" + jsr _scmpcom + beq :+ + bcs _2cmpstore +: dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 > n2, false if not +dword SGT,">" + jsr _scmpcom + beq _2cmpstore + bcc _2cmpstore + dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- f ) f = true if n1 >= n2, false if not +dword SGTE,">=" + jsr _scmpcom + beq :+ + bcc _2cmpstore +: dey + bra _2cmpstore +eword + +; H: ( n1 n2 -- n1|n2 ) return the greater of n1 or n2 +dword MAX,"MAX" + jsr _scmpcom + bcs drop + jsr _swap +drop: inx + inx + inx + inx + NEXT +eword + +; H: ( n1 n2 -- n1|n2 ) return the smaller of n1 or n2 +dword MIN,"MIN" + jsr _scmpcom + bcc drop + jsr _swap +drop: inx + inx + inx + inx + NEXT +eword + +; common routine for unsigned comparisons +.proc _ucmpcom + jsr _2parm + ldy #$0000 + lda STACKBASE+6,x + cmp STACKBASE+2,x + bne :+ + lda STACKBASE+4,x + cmp STACKBASE+0,x +: rts +.endproc + +; common routine for signed comparisons +.proc _scmpcom + jsr _2parm + ldy #$0000 + jmp _stest32 +.endproc + +; ( c-addr -- ) set dictionary pointer to c-addr +hword toHERE,"->HERE" + jsr _popay + sty DHERE + sta DHERE+2 + NEXT +eword + +; H: ( -- c-addr ) return dictionary pointer +dword HERE,"HERE" + ldy DHERE + lda DHERE+2 + PUSHNEXT +eword + +; ( -- c-addr ) return address of last definition in current vocabulary +; non-standard +dword LAST,"LAST" + ENTER + .dword GET_CURRENT + .dword FETCH + EXIT +eword + +hword dCURDEF,"$CURDEF" + SYSVAR SV_dCURDEF +eword + +; ( -- c-addr ) return address of $OLDHERE system variable +hword dOLDHERE,"$OLDHERE" + SYSVAR SV_OLDHERE +eword + +; ( -- c-addr ) return HERE address prior to starting current definition +; used by PATCH to forget partial definiton when uncaught exception occurs +hword OLDHERE,"OLDHERE" + ENTER + .dword dOLDHERE + .dword FETCH + EXIT +eword + +; ( -- ) exit current definition +dword DEXIT,"EXIT",F_CONLY + jmp _exit_next +eword + +; ( n -- ) read cell from instruction stream, discard if n is true, set IP if false +; word compiled by IF +hword _IF,"_IF" + jsr _popay + ora #$0000 + bne :+ + tya + bne :+ + jmp _JUMP::code + : jmp _SKIP::code +eword + +; ( n -- ) read cell from instruction stream, discard if n is false, set IP if true +hword _IFFALSE,"_IFFALSE" + jsr _popay + ora #$0000 + bne :+ + tya + bne :+ + jmp _SKIP::code +: jmp _JUMP::code +eword + +; ( x1 x2 -- x1 ) read cell from instruction stream, discard if x1 = x2, set IP if false +; saves some space in hand-coded routines that need CASE-like construction such as +; _MESSAGE +hword _IFEQUAL,"_IFEQUAL" + jsr _popay + cmp STACKBASE+2,x + bne :+ + tya + cmp STACKBASE+0,x + bne :+ + jmp _SKIP::code +: jmp _JUMP::code +eword + +; ( -- ) throw exception -22, control structure mismatch +; used for unresolved forward references +hword _CONTROL_MM,"_CONTROL_MM" + ldy #.loword(-22) + lda #.hiword(-22) + jmp _throway +eword + +; H: ( C: orig ) ( E: -- ) jump ahead as resolved by e.g. THEN +dword AHEAD,"AHEAD",F_IMMED|F_CONLY|F_TEMPD + ENTER + .dword _COMP_LIT + .dword _JUMP + .dword HERE + .dword _COMP_LIT + .dword _CONTROL_MM + EXIT +eword + +; H: ( C: if-sys ) ( E: n -- ) begin IF ... ELSE ... ENDIF +dword IF,"IF",F_IMMED|F_CONLY|F_TEMPD + ENTER + .dword _COMP_LIT + .dword _IF ; compile _IF + .dword HERE ; save to resolve later + .dword _COMP_LIT + .dword _CONTROL_MM ; compile unresolved + EXIT +eword + +; H: ( C: if-sys -- else-sys ) ( E: -- ) ELSE clause of IF ... ELSE ... THEN +dword ELSE,"ELSE",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _JUMP + .dword HERE ; to be resolved later + .dword _COMP_LIT + .dword _CONTROL_MM + .dword SWAP ; put IF's unresolved address in place + .dword HERE ; IF's false branch goes here + .dword SWAP + .dword STORE ; resolve IF + EXIT +eword + +; H: ( C: if-sys|else-sys -- ) ( E: -- ) +dword THEN,"THEN",F_IMMED|F_CONLY + ENTER + .dword HERE ; IF or ELSE branch goes here + .dword SWAP + .dword STORE ; resolve IF or ELSE + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: ( n1 n2 -- n1+n2 n1 ) +dword BOUNDS,"BOUNDS" + jsr _swap + lda STACKBASE+0,x + clc + adc STACKBASE+4,x + sta STACKBASE+4,x + lda STACKBASE+2,x + adc STACKBASE+6,x + sta STACKBASE+6,x + NEXT +eword + +; H: ( C: -- dest ) ( E: -- ) start a BEGIN loop +; BEGIN is basically an immediate HERE +dword BEGIN,"BEGIN",F_IMMED|F_CONLY|F_TEMPD + jmp HERE::code ; dest on stack +eword + +; H: ( C: dest -- orig dest ) ( E: x -- ) WHILE clause of BEGIN...WHILE...REPEAT loop +dword WHILE,"WHILE",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _IF + .dword HERE ; ( dest -- dest orig ) + .dword SWAP ; ( dest orig -- orig dest ) + .dword _COMP_LIT + .dword _CONTROL_MM + EXIT +eword + +; H: ( C: dest -- ) ( R: x -- ) UNTIL clause of BEGIN...UNTIL loop +dword UNTIL,"UNTIL",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _IF + .dword COMMA + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: ( C: orig dest -- ) (R: -- ) resolve orig and dest, repeat BEGIN loop +dword REPEAT,"REPEAT",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _JUMP + .dword COMMA + .dword HERE + .dword SWAP + .dword STORE + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: ( C: dest -- ) ( R: -- ) resolve dest, jump to BEGIN +dword AGAIN,"AGAIN",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _JUMP + .dword COMMA + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: ( n1|u1 n2|u2 n3|u3 -- f ) f = true if n2|u2 <= n1|u1 < n3|u3, false otherwise +dword WITHIN,"WITHIN" + ENTER + .dword OVER ; ( n1 n2 n3 -- n1 n2 n3 n2' ) + .dword MINUS ; ( n1 n2 n3 n2' -- n1 n2 n4 ) + .dword PtoR ; ( n1 n2 n4 -- n1 n2 ) ( R: -- n4 ) + .dword MINUS ; ( n1 n2 -- n5 ) + .dword RtoP ; ( n5 -- n5 n4 ) + .dword ULT ; ( n5 n4 -- f ) + EXIT +eword + +; H: ( n1|u1 n2|u2 n3|u3 -- f ) f = true if n2|u2 <= n1|u1 <= n3|u3, false otherwise +dword BETWEEN,"BETWEEN" + ENTER + .dword INCR + .dword WITHIN + EXIT +eword + +; ( limit start -- ) ( R: -- loop-sys ) +; Run-time semantics for DO +; loop-sys = ( leave-IP index limit ) +hword _DO,"_DO" + jsr _2parm + lda IP+2 ; put IP on stack for LEAVE target + pha + lda IP + pha + jsr _popay ; index + pha + phy + jsr _popay ; limit + pha + phy + jmp _SKIP2::code ; skip LEAVE target (usually a _JUMP) +eword + +; ( limit start -- ) ( R: -- loop-sys ) +; Run-time semantics for ?DO +hword _QDO,"_QDO" + jsr _2parm + lda IP+2 ; put IP on stack for LEAVE target + pha + lda IP + pha + jsr _popay ; index + pha + phy + jsr _popay ; limit + pha + phy + lda 1,s + cmp 5,s + bne doloop + lda 3,s + cmp 7,s + bne doloop + NEXT ; leave immediately +doloop: jmp _SKIP2::code ; enter loop +eword + +; H: Compilation: ( -- ) ( R: -- do-sys ) +; H: Execution: ( limit start -- ) begin DO loop +dword DO,"DO",F_IMMED|F_CONLY|F_TEMPD + ENTER + .dword _COMP_LIT + .dword _DO ; compile execution semantics +qdo: .dword HERE ; do-sys + .dword _COMP_LIT + .dword _JUMP ; LEAVE resumes execution here + .dword _COMP_LIT + .dword _CONTROL_MM ; LOOP/+LOOP will jump to do-sys+4, after this cell + EXIT +eword + +; H: Compilation: ( -- ) ( R: -- do-sys ) +; H: Execution: ( limit start -- ) begin DO loop, skip if limit=start +dword QDO,"?DO",F_IMMED|F_CONLY|F_TEMPD + ENTER + .dword _COMP_LIT + .dword _QDO + JUMP DO::qdo +eword + +; H: ( -- ) ( R: loop-sys -- ) remove loop parameters from stack +dword UNLOOP,"UNLOOP",F_CONLY + pla ; drop limit + pla + pla ; drop index + pla + pla ; drop leave-IP + pla + NEXT +eword + +; run-time semantics for +LOOP +; With ( i -- ) and ( R: index(5,7) limit(1,3) -- index' limit ) +; if new index in termination range, exit va _SKIP, otherwise via _JUMP +; stack-relative addressing is very helpful here +; WR will contain the limit, XR will contain the limit plus the loop increment +; We then see if the loop index is between them and if so we terminate the loop +hword _PLOOP,"_+LOOP" + jsr _1parm + lda 5,s ; Compute new index low byte + clc + adc STACKBASE+0,x ; increment low byte + sta 5,s ; write it back + lda 7,s ; new index high byte + adc STACKBASE+2,x ; increment high byte + sta 7,s ; write it back + jsr _stackdecr ; make some room on stack + jsr _stackdecr + lda 1,s ; compute termination bounds + sta STACKBASE+4,x + clc + adc STACKBASE+8,x + sta STACKBASE+0,x + lda 3,s + sta STACKBASE+6,x + adc STACKBASE+10,x + sta STACKBASE+2,x + lda 5,s ; finally, write new index into third stack entry + sta STACKBASE+8,x + lda 7,s + sta STACKBASE+10,x + ENTER + .dword TWODUP + .dword MAX + .dword PtoR + .dword MIN + .dword RtoP + .dword WITHIN + CODE + lda STACKBASE+0,x + ora STACKBASE+2,x + php + inx + inx + inx + inx + plp + beq :+ + jmp _SKIP::code +: jmp _JUMP::code +eword + +; H: Compilation: ( C: do-sys -- ) +; H: Execution: ( u|n -- ) add u|n to loop index and continue loop if within bounds +dword PLOOP,"+LOOP",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT ; compile execution semantics + .dword _PLOOP + .dword DUP ; ( loop-sys -- loop-sys loop-sys' ) + ONLIT 8 ; two cells + .dword PLUS ; ( loop-sys loop-sys' -- loop-sys loop-sys'' ) get target of loop jump + .dword COMMA ; ( loop-sys loop-sys'' -- loop-sys ) and compile as target of _PLOOP + .dword HERE ; ( loop-sys -- loop-sys t ) + .dword SWAP ; ( t -- loop-sys + .dword _COMP_LIT ; compile in an UNLOOP + .dword UNLOOP + ONLIT 4 ; one cell + .dword PLUS ; get address to resolve + .dword STORE ; and resolve all the leaves + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: Compilation: ( C: do-sys -- ) +; H: Execution: ( -- ) add 1 to loop index and continue loop if within bounds +dword LOOP,"LOOP",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword ONE + .dword PLOOP + EXIT +eword + +; H: ( -- ) exit loop +dword LEAVE,"LEAVE",F_CONLY + lda 9,s + tay + lda 11,s + jmp _JUMP::go +eword + +; H: ( f -- ) exit loop if f is nonzero +dword QLEAVE,"?LEAVE",F_CONLY + jsr _popay + ora #$0000 + bne LEAVE::code + tya + bne LEAVE::code + NEXT +eword + +; H: ( -- n ) copy inner loop index to stack +dword IX,"I",F_CONLY + lda 5,s + tay + lda 7,s + PUSHNEXT +eword + +; H: ( -- n ) copy second-inner loop index to stack +dword JX,"J",F_CONLY + lda 13,s + tay + lda 15,s + PUSHNEXT +eword + +.if 0 +; H: ( -- n ) copy third-inner loop index to stack +dword KX,"K",F_CONLY + lda 21,s + tay + lda 23,s + PUSHNEXT +eword +.endif + +; H: Compilation: ( R: -- case-sys ) start a CASE...ENDCASE structure +; H: Execution: ( -- ) +dword CASE,"CASE",F_IMMED|F_CONLY|F_TEMPD + ENTER + .dword _COMP_LIT + .dword _SKIP2 ; compile execution semantics + .dword HERE ; case-sys + .dword _COMP_LIT + .dword _JUMP ; ENDOF resumes execution here + .dword _COMP_LIT ; compile unresolved + .dword _CONTROL_MM + EXIT +eword + +; ( n1 n2 -- n1 ) run-time semantics of OF +; test against CASE value, SKIP if match +; otherwise JUMP (to cell after ENDOF) +hword _OF,"_OF" + jsr _2parm + lda STACKBASE+4,x + cmp STACKBASE+0,x + bne nomatch + lda STACKBASE+6,x + cmp STACKBASE+2,x + bne nomatch + jsr _stackincr ; drop test value + jsr _stackincr ; and value being tested + jmp _SKIP::code ; and skip jump target +nomatch: jsr _stackincr ; drop test value + jmp _JUMP::code ; go to jump target +eword + +; H: Compilation: ( case-sys -- case-sys of-sys ) begin an OF...ENDOF structure +; H: Execution: ( x1 x2 -- | x1 ) execute OF clause if x1 = x2, leave x1 on stack if not +dword OF,"OF",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _OF + .dword HERE ; of-sys + .dword _COMP_LIT ; compile unresolved + .dword _CONTROL_MM + EXIT +eword + +; H: Compilation; ( case-sys of-sys -- case-sys ) conclude an OF...ENDOF structure +; H: Execution: Continue execution at ENDCASE of case-sys +dword ENDOF,"ENDOF",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT ; compile a jump + .dword _JUMP + .dword OVER ; copy case-sys + .dword COMPILECOMMA ; which is the jump target + .dword HERE ; unmatched OF jumps here + .dword SWAP + .dword STORE ; resolve of-sys + EXIT +eword + +; H: Compilation: ( case-sys -- ) conclude a CASE...ENDCASE structure +; H: Execution: ( | n -- ) continue execution, dropping n if no OF matched +dword ENDCASE,"ENDCASE",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT ; compile drop value under test + .dword DROP + .dword HERE ; case-sys jump goes here + .dword SWAP + .dword CELLPLUS + .dword STORE ; resolve case-sys + .dword dTEMPSEMIQ ; see if we need to end a temporary def + EXIT +eword + +; H: ( -- ) store 16 to BASE +dword HEX,"HEX" + ENTER + ONLIT 16 + .dword BASE + .dword STORE + EXIT +eword + +; H: ( -- ) store 10 to BASE +dword DECIMAL,"DECIMAL" + ENTER + ONLIT 10 + .dword BASE + .dword STORE + EXIT +eword + +; H: ( -- ) store 2 to BASE +dword BINARY,"BINARY" + ENTER + ONLIT 2 + .dword BASE + .dword STORE + EXIT +eword + +; H: ( -- ) store 8 to BASE +dword OCTAL,"OCTAL" + ENTER + ONLIT 8 + .dword BASE + .dword STORE + EXIT +eword + +; H: ( n -- n' ) increment top stack item +dword INCR,"1+" + jsr _1parm +doinc: inc STACKBASE+0,x + bne :+ + inc STACKBASE+2,x +: NEXT +eword + +; H: ( n -- n' ) decrement top stack item +dword DECR,"1-" + jsr _1parm + lda STACKBASE+0,x + bne :+ + dec STACKBASE+2,x +: dec STACKBASE+0,x + NEXT +eword + +; H: ( n -- n' ) increment top stack item by 2 +dword TWOINCR,"2+" + jsr _1parm + lda STACKBASE+0,x + clc + adc #$02 + sta STACKBASE+0,x + bcc :+ + inc STACKBASE+2,x +: NEXT +eword + +; H: ( n -- n' ) decrement top stack item by 2 +dword TWODECR,"2-" + jsr _1parm + lda STACKBASE+0,x + sec + sbc #$02 + sta STACKBASE+0,x + bcs :+ + dec STACKBASE+2,x +: NEXT +eword + +; H: ( x -- x' ) invert the bits in x +dword INVERT,"INVERT" + jsr _1parm + jsr _invert + NEXT +eword + +; H: ( x -- x' ) invert the bits in x +dword NOT,"NOT" + bra INVERT::code +eword + +; H: ( n -- n' ) negate n +dword NEGATE,"NEGATE" + jsr _1parm + jsr _negate + NEXT +eword + +; H: ( n f -- n|n' ) if f < 0, then negate n +; non-standard +hword QNEGATE,"?NEGATE" + jsr _popay + and #$8000 + bne NEGATE::code + NEXT +eword + +; H: ( n -- n' ) take the absolute value of n +; we don't check parms on stack here because +; NEGATE will error if empty +dword ABS,"ABS" + lda STACKBASE+2,x + bpl :+ + jsr _negate +: NEXT +eword + +; H: ( d -- d' ) negate d +dword DNEGATE,"DNEGATE" + jsr _2parm + jsr _dnegate + NEXT ; push high cell +eword + +; H: ( d -- d' ) take the absolute value of d +dword DABS,"DABS" + lda STACKBASE+2,x + bpl :+ + jsr _dnegate +: NEXT +eword + +; H: ( n1 n2 -- n3 ) n3 = n1+n2 +dword PLUS,"+" + jsr _2parm + lda STACKBASE+4,x + clc + adc STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + adc STACKBASE+2,x + sta STACKBASE+6,x +stkinc: inx + inx + inx + inx + NEXT +eword + +; H: ( n1 n2 -- n3 ) n3 = n1-n2 +dword MINUS,"-" + jsr _2parm + lda STACKBASE+4,x + sec + sbc STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + sbc STACKBASE+2,x + sta STACKBASE+6,x + bra PLUS::stkinc +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 & n2 +dword LAND,"AND" + jsr _2parm + lda STACKBASE+4,x + and STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + and STACKBASE+2,x + sta STACKBASE+6,x + bra PLUS::stkinc +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 | n2 +dword LOR,"OR" + jsr _2parm + lda STACKBASE+4,x + ora STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + ora STACKBASE+2,x + sta STACKBASE+6,x + bra PLUS::stkinc +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 ^ n2 +dword LXOR,"XOR" + jsr _2parm + lda STACKBASE+4,x + eor STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + eor STACKBASE+2,x + sta STACKBASE+6,x + bra PLUS::stkinc +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 << n2 +dword LSHIFT,"LSHIFT" + jsr _2parm + jsr _popxr + ldy #.loword(shift-1) + lda #.hiword(shift-1) + jsr _iter_ay + NEXT +shift: asl STACKBASE+0,x + rol STACKBASE+2,x + clc + rtl +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 >> n2 +dword RSHIFT,"RSHIFT" + jsr _2parm + jsr _popxr + ldy #.loword(shift-1) + lda #.hiword(shift-1) + jsr _iter_ay + NEXT +shift: lsr STACKBASE+2,x + ror STACKBASE+0,x + clc + rtl +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 << n2 +dword LSHIFTX,"<<" + bra LSHIFT::code +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 >> n2 +dword RSHIFTX,">>" + bra RSHIFT::code +eword + +; H: ( n1 n2 -- n3 ) n3 = n1 >> n2, extending sign bit +dword ARSHIFT,">>A" + jsr _2parm + jsr _popxr + ldy #.loword(shift-1) + lda #.hiword(shift-1) + jsr _iter_ay + NEXT +shift: cmp #$8000 + ror STACKBASE+2,x + ror STACKBASE+0,x + clc + rtl +eword + +; H: ( n -- n' ) shift n1 one bit left +dword TWOMULT,"2*" + jsr _1parm + jsl LSHIFT::shift + NEXT +eword + +; H: ( n -- n' ) shift n1 one bit right +dword UTWODIV,"U2/" + jsr _1parm + jsl RSHIFT::shift + NEXT +eword + +; H: ( n -- n' ) shift n1 one bit right, extending sign bit +dword TWODIV,"2/" + jsr _1parm + jsl ARSHIFT::shift + NEXT +eword + +; H: ( n c-addr -- ) add n to value at c-addr +dword PSTORE,"+!" + ENTER + .dword DUP + .dword FETCH + .dword ROT + .dword PLUS + .dword SWAP + .dword STORE + EXIT +eword + +; H: ( d -- n ) convert double-number to number +dword DtoS,"D>S" + jmp DROP::code +eword + +; H: ( n -- d ) convert number to double-number +dword StoD,"S>D" + jsr _1parm + lda STACKBASE+2,x + and #$8000 + bpl :+ + lda #$FFFF +: tay + PUSHNEXT +eword + +; H: ( n n -- d d ) convert two numbers to double-numbers +dword TWOStoD,"2S>D" + ENTER + .dword PtoR + .dword StoD + .dword RtoP + .dword StoD + EXIT +eword + +; Factored for number conversion +.proc _dplus + lda STACKBASE+12,x + clc + adc STACKBASE+4,x + sta STACKBASE+12,x + lda STACKBASE+14,x + adc STACKBASE+6,x + sta STACKBASE+14,x + lda STACKBASE+8,x + adc STACKBASE+0,x + sta STACKBASE+8,x + lda STACKBASE+10,x + adc STACKBASE+2,x + sta STACKBASE+10,x +stkinc: txa + clc + adc #$08 + tax + rts +.endproc + +; H: ( d1 d2 -- d3 ) d3 = d1+d2 +dword DPLUS,"D+" + jsr _4parm + jsr _dplus + NEXT +eword + +; H: ( d1 d2 -- d3 ) d3 = d1-d2 +dword DMINUS,"D-" + jsr _4parm + lda STACKBASE+12,x + sec + sbc STACKBASE+4,x + sta STACKBASE+12,x + lda STACKBASE+14,x + sbc STACKBASE+6,x + sta STACKBASE+14,x + lda STACKBASE+8,x + sbc STACKBASE+0,x + sta STACKBASE+8,x + lda STACKBASE+10,x + sbc STACKBASE+2,x + sta STACKBASE+10,x + jsr _dplus::stkinc + NEXT +eword + +; System variables for temporary string buffers +hword dSBUF0,"$SBUF0" + SYSVAR SV_SBUF0 +eword + +hword dSBUF1,"$SBUF1" + SYSVAR SV_SBUF1 +eword + +hword dCSBUF,"$CSBUF" + SYSVAR SV_CSBUF +eword + +; ( c-addr1 u1 -- c-addr2 u1 ) +; Allocate a temporary string buffer for interpretation semantics of strings +; and return the address and length of the buffer +; if taking the slot used by an existing buffer, free it. +dword dTMPSTR,"$TMPSTR" + jsr _2parm + lda STACKBASE+0,x ; get u1 + sta XR + lda STACKBASE+2,x + bne nomem ; only going to support ~64K strings for this + sta XR+2 + jsr _alloc ; allocate memory for it + bcc nomem + pha ; save pointer + phy + ldy #SV_CSBUF ; get current string buffer + lda [SYSVARS],y + inc a + and #$01 ; only need low bit + sta [SYSVARS],y + pha ; save it + bne getbuf1 + ldy #SV_SBUF0+2 ; select buf 0 + bra getbuf +getbuf1: ldy #SV_SBUF1+2 ; select buf 1 +getbuf: lda [SYSVARS],y ; get buffer pointer + sta WR+2 ; into WR + dey + dey + lda [SYSVARS],y + sta WR + ora WR+2 + beq :+ ; no prior allocation if zero + jsr _free ; otherwise, free current memory +: lda STACKBASE+0,x ; length to XR + sta XR + lda STACKBASE+2,x + sta XR+2 + lda STACKBASE+4,x ; original address to WR + sta WR + lda STACKBASE+6,x + sta WR+2 + pla + bne setbuf1 + ldy #SV_SBUF0 ; select buf 0 + bra setbuf +setbuf1: ldy #SV_SBUF1 ; select buf 1 +setbuf: pla ; update pointers + sta YR ; in YR + sta [SYSVARS],y ; in the appropriate system var + sta STACKBASE+4,x ; in the parameter stack + iny + iny + pla + sta YR+2 + sta [SYSVARS],y + sta STACKBASE+6,x + jsr _move + NEXT +nomem: ldy #.loword(-18) + lda #.hiword(-18) + jmp _throway +eword + +; H: ( -- ' ' ) +dword BL,"BL" + lda #' ' + jsr _pusha + NEXT +eword + +; H: ( -- ) emit a space +dword SPACE,"SPACE" + ENTER + .dword BL + .dword EMIT + EXIT +eword + +; H: ( u -- ) emit u spaces +dword SPACES,"SPACES" + jsr _popxr + ldy #.loword(do_emit-1) + lda #.hiword(do_emit-1) + jsr _iter_ay + NEXT +do_emit: ENTER + .dword BL + .dword EMIT + CODE + clc + rtl +eword + +; H: ( -- ) +dword CARRET,"CARRET" + lda #c_cr + jsr _pusha + NEXT +eword + +; H: ( -- ) +dword LINEFEED,"LINEFEED" + lda #c_lf + jsr _pusha + NEXT +eword + +; H: ( -- ) emit a CR with no linefeed, set #OUT to 0 +dword pCR,"(CR" + ENTER + .dword CARRET + .dword EMIT + ONLIT 0 + .dword NOUT + .dword STORE + EXIT +eword + +; H: ( -- ) emit a LF +hword LF,"LF" + ENTER + .dword LINEFEED + .dword EMIT + EXIT +eword +; H: ( -- ) emit a CR/LF combination, set increment #LINE + +dword CR,"CR" + ENTER + ONLIT 1 + .dword NLINE + .dword PSTORE + .dword pCR + .dword LF + EXIT +eword + +; H: ( -- ) +dword BELL,"BELL" + lda #c_bell + jsr _pusha + NEXT +eword + +; H: ( -- ) +dword BS,"BS" + lda #c_bs + jsr _pusha + NEXT +eword + +; H: ( -- ) clear screen & home cursor (uses ANSI escape sequence) +dword PAGE,"PAGE" + ENTER + .dword _SLIT + .dword 7 + .byte $1B,"[2J",$1B,"[H" + .dword TYPE + EXIT +eword + +; H: ( u1 u2 -- ) place cursor at col u1 row u2 (uses ANSI escape sequence) +dword AT_XY,"AT-XY" + ENTER + ONLIT $1B + .dword EMIT + ONLIT '[' + .dword EMIT + .dword INCR + ONLIT UDOTZ + ONLIT 10 + .dword TMPBASE + ONLIT ';' + .dword EMIT + .dword INCR + ONLIT UDOTZ + ONLIT 10 + .dword TMPBASE + ONLIT 'H' + .dword EMIT + EXIT +eword + +; H: ( ud u1 -- u2 u3 ) divide ud by u1, giving quotient u3 and remainder u2 +dword UMDIVMOD,"UM/MOD" + jsr _3parm + lda STACKBASE+0,x + ora STACKBASE+2,x + beq _divzero + jsr _umdivmod + bcs _overflow + NEXT +eword + +; H: ( d n1 -- n2 n3 ) symmetric divide d by n1, giving quotient n3 and remainder n2 +dword SMDIVREM,"SM/REM" + .if 1 ; native version + jsr _3parm + lda STACKBASE+0,x + ora STACKBASE+2,x + beq _divzero + jsr _smdivrem + bcs _overflow + NEXT + .else ; secondary version + ENTER + .dword TWODUP + .dword LXOR ; compute result sign + .dword PtoR ; and save + .dword OVER ; copy dividend sign + .dword PtoR ; and save + .dword ABS ; take absolute value of args + .dword PtoR + .dword DABS + .dword RtoP + .dword UMDIVMOD ; perform unsigned division + .dword SWAP ; move quotient out of the way + .dword RtoP ; get dividend sign + .dword QNEGATE ; and negate the remainder if it should be negative + .dword SWAP ; put the quotient back + .dword RtoP ; get result sign + .dword QNEGATE ; and make negative if it should be negative + EXIT + .endif +eword + +; helpers to throw division errors +.proc _divzero + ldy #.loword(-10) + lda #.hiword(-10) + jmp _throway +.endproc + +.proc _overflow + ldy #.loword(-11) + lda #.hiword(-11) + jmp _throway +.endproc + +; H: ( n -- s ) s = -1 if n is negative, 0 if 0, 1 if positive +dword SIGNUM,"SIGNUM" + jsr _1parm + jsr _signum + NEXT +eword + +; H: ( d n1 -- n2 n3 ) floored divide d by n1, giving quotient n3 and remainder n2 +dword FMDIVMOD,"FM/MOD" + .if 1 ; primitive, using math lib FM/MOD code based on SM/REM + jsr _3parm + lda STACKBASE+0,x + ora STACKBASE+2,x + beq _divzero + jsr _fmdivmod + bcs _overflow + NEXT + .else ; secondary, using SM/REM + ENTER + .dword DUP + .dword PtoR + .dword SMDIVREM + .dword OVER + .dword SIGNUM + .dword RCOPY + .dword SIGNUM + .dword NEGATE + .dword EQUAL + .dword _IF + .dword else + .dword DECR + .dword SWAP + .dword RtoP + .dword PLUS + .dword SWAP + EXIT +else: .dword RDROP + EXIT + .endif +eword + +; H: ( u1 u2 -- u3 u4 ) divide u1 by u2, giving quotient u4 and remainder u3 +dword UDIVMOD,"U/MOD" + ENTER + .dword PtoR + .dword StoD + .dword RtoP + .dword UMDIVMOD + EXIT +eword + +; H: ( n1 n2 -- n3 n4 ) symmetric divide n1 by n2, giving quotient n4 and remainder n3 +dword DIVMOD,"/MOD" + ENTER + .dword PtoR + .dword StoD + .dword RtoP + .dword FMDIVMOD + EXIT +eword + +; H: ( n1 n2 -- n3 ) symmetric divide n1 by n2, giving remainder n3 +dword MOD,"MOD" + ENTER + .dword DIVMOD + .dword DROP + EXIT +eword + +; H: ( n1 n2 -- n3 ) symmetric divide n1 by n2, giving quotient n3 +dword DIV,"/" + ENTER + .dword DIVMOD + .dword NIP + EXIT +eword + +; H: ( n1 n2 n3 -- n4 n5 ) n4, n5 = symmetric rem, quot of n1*n2/n3 +dword MULTDIVMOD,"*/MOD" + ENTER + .dword PtoR + .dword MMULT + .dword RtoP + .dword FMDIVMOD + EXIT +eword + +; H: ( n1 n2 n3 -- n4 ) n4 = symmetric quot of n1*n2/n3 +dword MULTDIV,"*/" + ENTER + .dword MULTDIVMOD + .dword NIP + EXIT +eword + +; H: ( d1 n1 -- d2 n2 ) d2, n2 = remainder and quotient of d1/n1 +; unsigned 64-bit by 32-bit divide, leaving 64-bit quotient and 32-bit remainder +; used by double-number pictured numeric output routines only +dword UDDIVMOD,"UD/MOD" + ENTER + .dword PtoR + .dword ZERO + .dword RCOPY + .dword UMDIVMOD + .dword RtoP + .dword SWAP + .dword PtoR + .dword UMDIVMOD + .dword RtoP + EXIT +eword + +; H: ( u1 u2 -- ud ) ud = u1*u2 +dword UMMULT,"UM*" + jsr _2parm + jsr _umult + NEXT +eword + +; H: ( u1 u2 -- u3 ) u3 = u1*u2 +dword UMULT,"U*" + ENTER + .dword UMMULT + .dword DtoS + EXIT +eword + +; H: ( n1 n2 -- d ) d = n1*n2 +dword MMULT,"M*" + jsr _2parm + lda STACKBASE+2,x ; calculate sign flag + eor STACKBASE+6,x + pha ; save it for later + jsr _2abs + jsr _umult + pla + bpl :+ + jsr _dnegate +: NEXT +eword + +; H: ( n1 n2 -- n3 ) n3 = n1*n2 +dword MULT,"*" + ENTER + .dword MMULT + .dword DtoS + EXIT +eword + +; H: ( u1 -- u2 u3 ) u2 = closest square root <= to the true root, u3 = remainder +dword SQRTREM,"SQRTREM" + jsr _sqroot + NEXT +eword + +; H: ( n1 -- n2 ) if n1 is odd, n2=n1+1, otherwise n2=n1 +dword EVEN,"EVEN" + jsr _1parm + lda STACKBASE+0,x + and #1 + beq :+ + jmp INCR::code +: NEXT +eword + +; ( -- a-addr ) return address of WORD buffer +hword WORDBUF,"WORDBUF" + ENTER + .dword HERE + ONLIT 16 + .dword PLUS + EXIT +eword + +.if pad_size > 0 +; H: ( -- a-addr ) return address of PAD +dword PAD,"PAD" + ENTER + .dword WORDBUF + ONLIT word_buf_size + .dword PLUS + EXIT +eword +.endif + +; ( -- a-addr ) variable containing pictured numeric output pointer +hword dPPTR,"$PPTR" + SYSVAR SV_dPPTR +eword + +; H: ( -- ) begin pictured numeric output +dword PBEGIN,"<#" + ENTER + .dword WORDBUF + ONLIT word_buf_size + .dword PLUS + .dword dPPTR + .dword STORE + EXIT +eword + +; H: ( c -- ) place c in pictured numeric output +dword PHOLD,"HOLD" + ENTER + .dword dPPTR + .dword FETCH + .dword DECR + .dword DUP + .dword dPPTR + .dword STORE + .dword CSTORE + EXIT +eword + +; H: ( n -- ) place - in pictured numeric output if n is negative +dword PSIGN,"SIGN" + jsr _popay + and #$8000 + beq :+ + lda #'-' + jsr _pusha + jmp PHOLD::code +: NEXT +eword + +; H: ( ud1 -- ud2 ) divide ud1 by BASE, convert remainder to char and HOLD it, ud2 = quotient +dword PNUM,"#" + ENTER + .dword BASE + .dword FETCH + .dword UDDIVMOD + .dword ROT + CODE +hold: jsr _popay + tya + jsr _d_to_c + jsr _pusha + jmp PHOLD::code +eword + +; H: ( u1 -- u2 ) divide u1 by BASE, convert remainder to char and HOLD it, u2 = quotient +dword PUNUM,"U#" + ENTER + .dword ZERO + .dword BASE + .dword FETCH + .dword UMDIVMOD + .dword SWAP + CODE + bra PNUM::hold +eword + +; H: ( ud -- 0 ) perform # until quotient is zero +dword PNUMS,"#S" + ENTER +another: .dword PNUM + .dword TWODUP + .dword LOR + .dword _IFFALSE + .dword another + EXIT +eword + +; H: ( u -- 0 ) perform U# until quotient is zero +dword PUNUMS,"U#S" + ENTER +another: .dword PUNUM + .dword DUP + .dword _IFFALSE + .dword another + EXIT +eword + +; H: ( ud -- ) conclude pictured numeric output +dword PDONE,"#>" + ENTER + .dword TWODROP +getstr: .dword dPPTR + .dword FETCH + .dword WORDBUF + ONLIT word_buf_size + .dword PLUS + .dword dPPTR + .dword FETCH + .dword MINUS + EXIT +eword + +; H: ( u -- ) conclude pictured numeric output +dword PUDONE,"U#>" + ENTER + .dword DROP + JUMP PDONE::getstr +eword + +; ( d f -- c-addr u), f = true if signed number +hword dUDFMT,"$UDFMT" + ENTER + .dword _IF + .dword ns + .dword DUP + .dword PtoR + .dword DABS + JUMP doit +ns: .dword ZERO + .dword PtoR +doit: .dword PBEGIN + .dword PNUMS + .dword RtoP + .dword PSIGN + .dword PDONE + EXIT +eword + +; ( n f -- c-addr u), f = true if signed number +hword dUFMT,"$UFMT" +.if 1 ; slightly smaller & slower + ENTER + .dword _IF + .dword ns + .dword DUP + .dword PtoR + .dword ABS + JUMP :+ +ns: .dword ZERO + .dword PtoR +: .dword ZERO ; we already saved the sign, no need to sign-extend + JUMP dUDFMT::doit +.else ; bigger & faster + ENTER + .dword _IF + .dword ns + .dword DUP + .dword PtoR + .dword ABS + JUMP doit +ns: .dword ZERO + .dword PtoR +doit: .dword PBEGIN + .dword PUNUMS + .dword RtoP + .dword PSIGN + .dword PUDONE + EXIT +.endif +eword + +; H: ( n -- c-addr u ) convert n to text via pictured numeric output +dword NTOTXT,"(.)" + ENTER + .dword TRUE + .dword dUFMT + EXIT +eword + +; H: ( u -- c-addr u ) convert u to text via pictured numeric output +dword UTOTXT,"(U.)" + ENTER + .dword FALSE + .dword dUFMT + EXIT +eword + +; H: ( c-addr u1 u2 ) output c-addr u1 in a field of size u2 +hword DFIELD,"$FIELD" + ENTER + .dword OVER ; ( c-addr u1 u2 -- c-addr u1 u2 u1' ) + .dword MINUS ; ( c-addr u1 u2 u1' -- c-addr u1 u3 ) u3=remaining field + .dword DUP ; ( c-addr u1 u3 -- c-addr u1 u3 u3' + .dword ZEROLT ; ( c-addr u1 u3 u3' -- c-addr u1 u3 f ) + .dword _IF ; ( c-addr u1 u3 f -- c-addr u1 u3 ) + .dword :+ ; 0 or more in field, go print some spaces + .dword DROP + .dword TYPE + EXIT +: .dword SPACES + .dword TYPE + EXIT +eword + +; H: ( d u -- ) output d in a field of u chars +dword DDOTR,"D.R" + ENTER + .dword PtoR + .dword TRUE + .dword dUDFMT + .dword RtoP + .dword DFIELD + EXIT +eword + +; H: ( d -- ) output d +dword DDOT,"D." + ENTER + .dword TRUE + .dword dUDFMT + .dword TYPE + .dword SPACE + EXIT +eword + +; H: ( u1 u2 -- ) output u1 in a field of u2 chars +dword UDOTR,"U.R" + ENTER + .dword PtoR + .dword FALSE + .dword dUFMT + .dword RtoP + .dword DFIELD + EXIT +eword + +; ( u1 -- ) output u1 with no trailing space +dword UDOTZ,"U.0" + ENTER + .dword ZERO + .dword UDOTR + EXIT +eword + +; H: ( n u -- ) output n in a field of u chars +dword DOTR,".R" + ENTER + .dword PtoR + .dword TRUE + .dword dUFMT + .dword RtoP + .dword DFIELD + EXIT +eword + +; H: ( u -- ) output u +dword UDOT,"U." + ENTER + .dword FALSE + .dword dUFMT + .dword TYPE + .dword SPACE + EXIT +eword + +; H: ( n -- ) output n +dword DOT,"." + ENTER + .dword TRUE + .dword dUFMT + .dword TYPE + .dword SPACE + EXIT +eword + +; H: ( n -- ) output n +dword SDOT,"S." + bra DOT::code +eword + +; H: ( a-addr -- ) output signed contents of cell at a-addr +dword SHOW,"?" + ENTER + .dword FETCH + .dword DOT + EXIT +eword + +; H: ( n -- ) output n in decimal base +dword DOTD,".D" + ENTER + ONLIT 10 +tmpbase: ONLIT DOT + .dword SWAP + .dword TMPBASE + EXIT +eword + +; H: ( n -- ) output n in hexadecimal base +dword DOTH,".H" + ENTER + ONLIT 16 + JUMP DOTD::tmpbase +eword + +; H: ( addr1 addr2 len -- ) move memory +dword MOVE,"MOVE" + jsr _popxr + jsr _popyr + jsr _popwr + jsr _move + NEXT +eword + +; H: ( addr1 addr2 len -- ) move memory +dword CMOVE,"CMOVE" + bra MOVE::code +eword + +; H: ( addr1 addr2 len -- ) move memory up +dword CMOVEUP,"CMOVE>" + jsr _popxr + jsr _popyr + jsr _popwr + jsr _moveup + NEXT +eword + +; H: ( addr1 addr2 u1 -- n1 ) compare two strings of length u1 +; IEEE 1275 +dword COMP,"COMP" + stz ZR ; case sensitive +docomp: jsr _popxr ; length + jsr _popyr ; addr2 + jsr _popwr ; addr1 + sep #SHORT_A + .a8 + ldy #$0000 +lp: cpy XR + bcs equal + bit ZR + bmi insens + lda [WR],y ; case sensitive compare + cmp [YR],y +postcmp: bne neq + iny + bra lp +insens: lda [WR],y ; case insensitive compare + jsr _cupper8 + sta ZR+2 ; use ZR+2 to hold converted byte + lda [YR],y + jsr _cupper8 + cmp ZR+2 + bra postcmp +neq: rep #SHORT_A + .a16 + bcc less + lda #$0000 + tay + iny + PUSHNEXT +less: lda #$FFFF + tay + PUSHNEXT +equal: rep #SHORT_A + .a16 + lda #$0000 + tay + PUSHNEXT +eword + +; H: ( addr1 addr2 u1 -- n1 ) case-insensitive compare two strings of length u1 +; non-standard +dword CICOMP,"CICOMP" + stz ZR + dec ZR + bra COMP::docomp +eword + +; H: ( addr1 u1 addr2 u2 -- n1 ) compare two strings +; ANS Forth +dword COMPARE,"COMPARE" + ENTER + .dword ROT ; ( addr1 u1 addr2 u2 -- addr1 addr2 u2 u1 ) + .dword TWODUP + .dword TWOPtoR ; ( R: -- u2' u1' ) + .dword MIN + .dword COMP + .dword DUP + .dword _IF + .dword equal + .dword RDROP + .dword RDROP + EXIT +equal: .dword DROP + .dword TWORtoP + .dword SWAP + .dword MINUS + .dword SIGNUM + EXIT +eword + +; H: ( c-addr1 u1 n -- c-addr2 u2 ) adjust string +dword sSTRING,"/STRING" +.if 1 ; secondary - shorter, slower + ENTER + .dword TUCK + .dword MINUS + .dword PtoR + .dword PLUS + .dword RtoP + EXIT +.else ; primitive - longer, faster + jsr _3parm + lda STACKBASE+8,x + clc + adc STACKBASE+0,x + sta STACKBASE+8,x + lda STACKBASE+10,x + adc STACKBASE+2,x + sta STACKBASE+10,x + lda STACKBASE+4,x + sec + sbc STACKBASE+0,x + sta STACKBASE+4,x + lda STACKBASE+6,x + sbc STACKBASE+2,x + sta STACKBASE+6,x + jsr _stackincr + NEXT +.endif +eword + +; H: ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) +; WR XR YR ZR +; in practice ZR can only be 16-bit like most other string stuff +dword SEARCH,"SEARCH" + jsr _4parm + jsr _popay + sty ZR + sta ZR+2 + jsr _popyr + lda STACKBASE+0,x ; now we are down to ( c-addr1 u1 ) on stack + sta XR ; get them and put them into WR and XR + lda STACKBASE+2,x + sta XR+2 + lda STACKBASE+4,x + sta WR + lda STACKBASE+6,x + sta WR+2 + bra chklen +next: rep #SHORT_A + .a16 + jsr _incwr + jsr _decxr +chklen: lda XR+2 + cmp ZR+2 + bne :+ + lda XR + cmp ZR +: bcc nomatch ; XR < ZR, no match found! + ldy ZR ; let's see if there's a match + beq nomatch ; nope out of u2 is zero + sep #SHORT_A + .a8 +lp: dey ; it needs to be one less than + lda [WR],y + cmp [YR],y + bne next + cpy #$0000 + bne lp ; keep matching + rep #SHORT_A + .a16 + lda WR+2 ; match found, return results! + sta STACKBASE+6,x + lda WR + sta STACKBASE+4,x + lda XR+2 + sta STACKBASE+2,x + lda XR + sta STACKBASE+0,x + lda #$FFFF + bra :+ +nomatch: lda #$0000 +: tay + PUSHNEXT +eword + +; H: ( addr len char -- ) fill memory with char +dword FILL,"FILL" + ENTER + .dword NROT + CODE + ldy #.loword(dofill-1) + lda #.hiword(dofill-1) + jsr _str_op_ays + jsr _stackincr + NEXT +dofill: sep #SHORT_A + .a8 + lda STACKBASE+0,x + sta [WR] + rep #SHORT_A + .a16 + clc + rtl +eword + +; H: ( addr len -- ) fill memory with spaces +dword BLANK,"BLANK" + ENTER + ONLIT ' ' + .dword FILL + EXIT +eword + +; H: ( addr len -- ) zero fill memory with spaces +dword ERASE,"ERASE" + ENTER + .dword ZERO + .dword FILL + EXIT +eword + +; H: ( addr len -- ) perform WBFLIP on the words in memory +dword WBFLIPS,"WBFLIPS" + ldy #.loword(doflip-1) + lda #.hiword(doflip-1) + jsr _str_op_ays + NEXT +doflip: lda [WR] + xba + sta [WR] + jsr _incwr + clc + rtl +eword + +; H: ( addr len -- ) perform LBFLIP on the cells in memory +dword LBFLIPS,"LBFLIPS" + ldy #.loword(doflip-1) + lda #.hiword(doflip-1) + jsr _str_op_ays + NEXT +doflip: ldy #$02 + lda [WR] + xba + pha + lda [WR],y + xba +cont: sta [WR] + pla + sta [WR],y + lda WR + clc + adc #.loword(3) + sta WR + lda WR+2 + adc #.hiword(3) + sta WR+2 + clc + rtl +eword + +; H: ( addr len -- ) perform LWFLIP on the cells in memory +dword LWFLIPS,"LWFLIPS" + ldy #.loword(doflip-1) + lda #.hiword(doflip-1) + jsr _str_op_ays + NEXT +doflip: ldy #$02 + lda [WR] + pha + lda [WR],y + bra LBFLIPS::cont +eword + +.if include_fcode +; FCode support words + +; H: ( addr -- char true ) access memory at addr, returning char +dword CPEEK,"CPEEK" + ENTER + .dword CFETCH + .dword TRUE + EXIT +eword + +; H: ( addr -- word true ) access memory at addr, returning word +dword WPEEK,"WPEEK" + ENTER + .dword WFETCH + .dword TRUE + EXIT +eword + +; H: ( addr -- cell true ) access memory at addr, returning cell +dword LPEEK,"LPEEK" + ENTER + .dword LFETCH + .dword TRUE + EXIT +eword + +; H: ( char addr -- true ) store char at addr +dword CPOKE,"CPOKE" + ENTER + .dword CSTORE + .dword TRUE + EXIT +eword + +; H: ( word addr -- true ) store word at addr +dword WPOKE,"WPOKE" + ENTER + .dword WSTORE + .dword TRUE + EXIT +eword + +; H: ( cell addr -- true ) store cell at addr +dword LPOKE,"LPOKE" + ENTER + .dword LSTORE + .dword TRUE + EXIT +eword + +; FCode evaluator variables: + +; Variable containing FCode instruction pointer +hword dFCODE_IP,"$FCODE-IP" + SYSVAR SV_FCODE_IP +eword + +; If set nonzero, FCode interpretation will end and the value thrown +hword dFCODE_END,"$FCODE-END" + SYSVAR SV_FCODE_END +eword + +; Bytes to increment $FCODE-IP for an FCode fetch. Nearly always 1. +hword dFCODE_SPREAD,"$FCODE-SPREAD" + SYSVAR SV_FCODE_SPREAD +eword + +; If zero, the FCode offset size is 8 bits, otherwise 16. +hword dFCODE_OFFSET,"$FCODE-OFFSET" + SYSVAR SV_FCODE_OFFSET +eword + +; Contains the XT of the FCode fetch instruction, usually RB@ +hword dFCODE_FETCH,"$FCODE-FETCH" + SYSVAR SV_FCODE_FETCH +eword + +; Contains the address of the FCode Master Table +hword dFCODE_TABLES,"$FCODE-TABLES" + SYSVAR SV_FCODE_TABLES +eword + +; Contains the address of the last defined FCode function +hword dFCODE_LAST,"$FCODE-LAST" + SYSVAR SV_FCODE_LAST +eword + +; If one, place headers on header-optional Fcode functions +; set by $BYTE-EXEC to the result of FCODE-DEBUG? if it exists +hword dFCODE_DEBUG,"$FCODE-DEBUG" + SYSVAR SV_FCODE_DEBUG +eword + +; H: ( -- u ) Return FCode revision +dword xFCODE_REVISION,"FCODE-REVISION" + ENTER + ONLIT $87 + .dword DO_TOKEN + EXIT +eword + +; H: ( -- ) display FCode IP and byte, throw exception -256 +dword FERROR,"FERROR" + ENTER + .dword dFCODE_IP + .dword FETCH + .dword DUP + .dword UDOT + .dword CFETCH + .dword UDOT + ONLIT -256 + .dword THROW + EXIT +eword + +; H: ( xt fcode# f -- ) set fcode# to execute xt, immediacy f +dword SET_TOKEN,"SET-TOKEN" + jml xSET_TOKEN_code +eword + +; H: ( fcode# -- xt f ) get fcode#'s xt and immediacy +dword GET_TOKEN,"GET-TOKEN" + jsr _1parm + jsl lGET_TOKEN + NEXT +eword + +; FCode atomic memory accessors, IEEE 1275-1994 says these may be overwritten by FCode +; to do device-specific accesses. + +; ( addr -- char ) fetch char at addr, atomically +hword dRBFETCH,"$RB@" + jmp CFETCH::code +eword + +; ( addr -- word ) fetch word at addr +; Note that IEEE 1275-1994 requires the fetch to occur in a single access, but the '816 +; has an 8-bit bus so this is technically impossible. +hword dRWFETCH,"$RW@" + jmp WFETCH::code +eword + +; ( addr -- cell ) fetch cell at addr +; Note that IEEE 1275-1994 requires the fetch to occur in a single access, but the '816 +; has an 8-bit bus so this is technically impossible. +hword dRLFETCH,"$RL@" + jmp LFETCH::code +eword + +; ( byte addr -- ) store byte at addr, atomically +hword dRBSTORE,"$RB!" + jmp CSTORE::code +eword + +; ( word addr -- ) store word at addr +; Note that IEEE 1275-1994 requires the store to occur in a single access, but the '816 +; has an 8-bit bus so this is technically impossible. +hword dRWSTORE,"$RW!" + jmp WSTORE::code +eword + +; ( cell addr -- ) store cell at addr +; Note that IEEE 1275-1994 requires the store to occur in a single access, but the '816 +; has an 8-bit bus so this is technically impossible. +hword dRLSTORE,"$RL!" + jmp LSTORE::code +eword + +; H: ( addr -- byte ) perform FCode-equivalent RB@: fetch byte +dword RBFETCH,"RB@",F_IMMED + ENTER + ONLIT $230 + .dword DO_TOKEN + EXIT +eword + +; H: ( addr -- word ) perform FCode-equivalent RW@: fetch word +dword RWFETCH,"RW@",F_IMMED + ENTER + ONLIT $232 + .dword DO_TOKEN + EXIT +eword + +; H: ( addr -- cell ) perform FCode-equivalent RL@: fetch cell +dword RLFETCH,"RL@",F_IMMED + ENTER + ONLIT $234 + .dword DO_TOKEN + EXIT +eword + +; H: ( byte addr -- ) perform FCode-equivalent RB!: store byte +dword RBSTORE,"RB!",F_IMMED + ENTER + ONLIT $231 + .dword DO_TOKEN + EXIT +eword + +; H: ( word addr -- ) perform FCode-equivalent RW!: store word +dword RWSTORE,"RW!",F_IMMED + ENTER + ONLIT $233 + .dword DO_TOKEN + EXIT +eword + +; H: ( cell addr -- ) perform FCode-equivalent RL!, store cell +dword RLSTORE,"RL!",F_IMMED + ENTER + ONLIT $235 + .dword DO_TOKEN + EXIT +eword + +.if 0 ; stuff for testing +dword xSET_MUTABLE_FTABLES,"SET-MUTABLE-FTABLES" + ENTER + .dword SET_MUTABLE_FTABLES + EXIT +eword + +dword xSET_RAM_FTABLE,"SET-RAM-FTABLE" + ENTER + .dword SET_RAM_FTABLE + EXIT +eword + +dword xSET_ROM_FTABLE,"SET-ROM-FTABLE" + ENTER + .dword SET_ROM_FTABLE + EXIT +eword + +dword xGET_FTABLES,"GET-FTABLES" + ENTER + .dword GET_FTABLES + EXIT +eword + +dword xSAVE_FCODE_STATE,"SAVE-FCODE-STATE" + ENTER + .dword SAVE_FCODE_STATE + EXIT +eword + +dword xRESTORE_FCODE_STATE,"RESTORE-FCODE-STATE" + ENTER + .dword RESTORE_FCODE_STATE + EXIT +eword +.endif + +.if 0 ; more testing stuff +dword TEST_FCODE,"TEST-FCODE" + jsl _pushda + .incbin "t/test.fc" +eword +.endif + +; FCode evaluation +; this does *not* save and restore the FCode evaluator state, that's what byte-load is +; for. This just gets things going, and unless SET-TOKEN is called, sticks with the ROM +; FCode tables. +; H: ( addr xt -- ) evaluate FCode at addr with fetch function xt, do not save state +dword dBYTE_EXEC,"$BYTE-EXEC" + jsr _2parm + ENTER + SLIT "FCODE-DEBUG?" ; see if user wants optional headers + .dword dFIND + .dword _IF + .dword nope + .dword EXECUTE + .dword dFCODE_DEBUG + .dword STORE + .dword _SKIP +nope: .dword TWODROP + .dword DUP + .dword ONE + .dword ULTE + .dword _IF + .dword usext + .dword DROP ; Drop supplied xt + ONLIT $230 ; RB@ + .dword GET_TOKEN ; get XT + .dword DROP ; drop the flag +usext: .dword dFCODE_FETCH ; and put it in $FCODE-FETCH + .dword STORE + .dword DECR ; need to start with address -1 + .dword dFCODE_IP + .dword STORE + .dword ONE + .dword dFCODE_SPREAD + .dword STORE + .dword dFCODE_END + .dword OFF + .dword dFCODE_OFFSET + .dword OFF + .dword xFCODE_EVALUATE + EXIT +eword + +; H: ( addr xt -- ) sav state, evaluate FCode at addr with fetch function xt, restore state +dword BYTE_LOAD,"BYTE-LOAD" + ENTER + .dword SAVE_FCODE_STATE + .dword PtoR + ONLIT dBYTE_EXEC + .dword CATCH + ;.dword DOTS + .dword RtoP + .dword RESTORE_FCODE_STATE + .dword THROW + EXIT +eword +.endif ; end of FCode stuff + +; H: ( addr len -- ) dump memory +dword DUMP,"DUMP" + ENTER + .dword BOUNDS + JUMP addr +lp: .dword DUP + ONLIT $F + .dword LAND + .dword _IFFALSE + .dword noaddr +addr: .dword CR + .dword DUP + ONLIT 8 + .dword UDOTR + ONLIT ':' + .dword EMIT + .dword SPACE +noaddr: .dword DUP + .dword CFETCH + ONLIT 2 + .dword UDOTR + .dword SPACE + .dword INCR + .dword TWODUP + .dword ULTE + .dword _IF + .dword lp + .dword TWODROP + EXIT +eword + +; H: ( xt -- addr|0 ) get link field of function at xt or 0 if none +dword rLINK,">LINK" + jsr _popyr + jsr _xttohead + bcc nolink + ldy YR + lda YR+2 + PUSHNEXT +nolink: lda #$0000 + tay + PUSHNEXT +eword + +; H: ( xt -- c-addr u ) get string name of function at xt, or ^xt if anonymous/noname +dword rNAME,">NAME" + ENTER + .dword ZERO ; ( xt -- xt 0 ) + .dword PtoR ; ( xt 0 -- xt ) ( R: -- 0 ) +lp: .dword RCOPY ; ( xt u ) + ONLIT NAMEMSK ; ( xt u -- xt u u1 ) + .dword UGT ; ( xt u u1 -- xt f ) is name too long? + .dword _IFFALSE ; ( xt f -- xt ) + .dword noname ; True branch, stack is ( xt 0 ) (R: u ) + .dword DUP ; ( xt -- xt xt' ) + .dword RCOPY ; ( xt xt' - xt xt' u ) + .dword INCR ; ( xt xt' u -- xt xt' u' ) + .dword MINUS ; ( xt xt' u' -- xt xt'' ) + .dword CFETCH ; ( xt xt'' -- xt c ) + .dword DUP ; ( xt c -- xt c c' ) + ONLIT $80 ; ( xt c c' -- xt c c' $80 ) + .dword LAND ; ( xt c c' -- xt c f ) + .dword _IFFALSE ; ( xt c f -- xt c ) + .dword done ; true branch + .dword DROP ; ( xt c -- xt ) + .dword RINCR ; ( xt ) ( R: u -- u' ) + JUMP lp +done: ONLIT NAMEMSK ; ( xt c -- xt c m ) + .dword LAND ; ( xt c m -- xt l ) l = length + .dword RCOPY ; ( xt l -- xt l u ) ( R: u ) + .dword EQUAL ; ( xt l u -- xt f ) + .dword _IF ; ( xt f -- xt ) + .dword noname ; false branch, stack is ( xt ) ( R: u ) + .dword RCOPY ; ( xt -- xt u ) ( R: u ) + .dword QDUP ; ( xt u -- xt u | xt u u ) + .dword _IF ; ( xt u | xt u u -- xt | xt u ) + .dword noname ; false branch, stack is ( xt ) ( R: u ) + .dword MINUS ; ( xt u -- c-addr ) + .dword RtoP ; ( c-addr -- c-addr u ) + EXIT +noname: .dword RDROP ; ( xt ) ( R: u -- ) +noname1: .dword PBEGIN + .dword PUNUMS ; ( xt -- ) + ONLIT '^' + .dword PHOLD + .dword PUDONE ; ( -- c-addr u ) + EXIT +eword +rNAME_noname1 = rNAME::noname1 + +; H: ( c-addr -- c-addr+1 u ) count packed string at c-addr +dword COUNT,"COUNT" + ENTER + .dword DUP + .dword INCR + .dword SWAP + .dword CFETCH + EXIT +eword + +; H: ( str len addr -- addr ) pack string into addr, similar to PLACE in some Forths +dword PACK,"PACK" + jsr _3parm + jsr _popyr + jsr _popxr + jsr _popwr + lda XR+2 + bne bad + lda XR + cmp #$100 + bcs bad + sta [YR] + ldy YR + lda YR+2 + jsr _pushay + inc YR + bne :+ + inc YR+2 +: jsr _move + NEXT +bad: ldy #.loword(-18) + lda #.hiword(-18) + jmp _throway +eword + +; H: ( c-addr u1 -- c-addr u2 ) u2 = length of string with trailing spaces omitted +dword MTRAILING,"-TRAILING" + lda STACKBASE+4,x + sta WR + lda STACKBASE+6,x + sta WR+2 + jsr _decwr + ldy STACKBASE+0,x +lp: lda [WR],y + and #$FF + cmp #' ' + bne done + dey + bne lp +done: sty STACKBASE+0,x + NEXT +eword + +; H: ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) convert text to number +; note: only converts positive numbers! +dword GNUMBER,">NUMBER" + jsr _4parm + ldy #SV_BASE+2 + lda [SYSVARS],y + sta YR+2 + dey + dey + lda [SYSVARS],y + sta YR + jsr _popxr ; u1 (length) + jsr _popwr ; c-addr1 ( stack is now just d ) +digit: lda XR ; see if no more chars left + ora XR+2 + beq done + lda [WR] + and #$FF ; enforce char + jsr _c_to_d ; convert to digit + bcc done ; if out of range, can't use it + cmp YR ; check against base + bcs done ; if >=, can't use it + .if 1 + jsr _pusha ; ( -- ud1l ud1h n ) + jsr _swap ; ( -- ud1l n ud1h ) + ldy YR + lda #$0000 + jsr _pushay ; ( -- ud1l n ud1h base ) + jsr _umult ; ( -- ud1l n ud1h*basel 0 ) + inx + inx + inx + inx ; ( -- ud1l n ud1h*basel ) + jsr _rot ; ( -- n ud1h*basel ud1l ) + ldy YR + lda #$0000 + jsr _pushay ; ( -- n ud1h*basel ud1l base ) + jsr _umult ; ( -- n ud1h*basel ud1l*basel ud1l*baseh ) + jsr _dplus ; ( -- ud2 ) + .else + pha ; save converted digit + lda YR + sta STACKBASE+0,x ; replace high cell of ud with base + stz STACKBASE+2,x ; base should never be > 65535! + jsr _umult ; multiply ud cells together + pla ; get digit back + clc + adc STACKBASE+4,x ; low order word of low order cell + sta STACKBASE+4,x + lda STACKBASE+6,x ; high order word of low order cell + adc #$00 + sta STACKBASE+6,x + stz STACKBASE+0,x ; zero the high word + stz STACKBASE+2,x + .endif + jsr _decxr + jsr _incwr + bra digit +done: ldy WR + lda WR+2 + jsr _pushay + ldy XR + lda XR+2 + PUSHNEXT +eword + +; H: ( str len char -- r-str r-len l-str l-len ) parse string for char, returning +; H: the left and right sides +dword LEFT_PARSE_STRING,"LEFT-PARSE-STRING" + jsr _popyr ; char + jsr _popxr ; len + jsr _popwr ; str + ldy #$0000 + lda XR + ora XR+2 + beq done +lp: lda [WR],y + and #$00FF + iny + beq done + cmp YR + beq done + cpy XR + bcc lp + ldy #$0000 +done: tya + beq nomatch + sta XR+2 + lda WR ; addr of str 2 = WR+(XR+2) + clc + adc XR+2 + tay + lda WR+2 + adc #$0000 + jsr _pushay + lda XR ; len of str 2 = XR-(XR+2) + sec + sbc XR+2 + jsr _pusha + ldy WR + lda WR+2 + jsr _pushay + ldy XR+2 + dey +: lda #$0000 + PUSHNEXT +nomatch: jsr _pushay + jsr _pushay + ldy WR + lda WR+2 + jsr _pushay + ldy XR + bra :- +eword + +; H: ( str len -- val.lo val.hi ) parse two integers from string in the form "n2,n2" +dword PARSE_2INT,"PARSE-2INT" + ENTER + ONLIT ',' + .dword LEFT_PARSE_STRING + .dword TWOPtoR + .dword ZERO + .dword StoD + .dword TWOSWAP + .dword GNUMBER + .dword THREEDROP + .dword ZERO + .dword StoD + .dword TWORtoP + .dword GNUMBER + .dword THREEDROP + EXIT +eword + +; ( c-addr u wid -- xt ) search wordlist wid for word +hword dWLSEARCH,"$WLSEARCH" + jsr _popwr + ldy #$02 + lda [WR],y + sta YR+2 + dey + dey + lda [WR],y + sta YR + jsr _popxr + jsr _popwr + jsr _search_unsmudged + PUSHNEXT +eword + +.if max_search_order > 0 +; H: ( c-addr u wid -- 0 | xt +-1 ) search wordlist for word +dword SEARCH_WORDLIST,"SEARCH-WORDLIST" +.else +hword SEARCH_WORDLIST,"SEARCH-WORDLIST" +.endif + ENTER + .dword dWLSEARCH + .dword DUP + .dword _IF + .dword notfound + .dword IMMEDQ + ONLIT 1 + .dword LOR + .dword NEGATE +notfound: EXIT +eword + +; H: ( c-addr u -- 0 | xt +-1 ) search for word in current search order +dword SEARCH_ALL,"$SEARCH" + ENTER +.if max_search_order > 0 + .dword dORDER + .dword FETCH + .dword QDUP + .dword _IF + .dword noorder +lp: .dword PtoR ; ( c-addr u1 u2 -- c-addr u1 ) + .dword TWODUP ; ( c-addr u1 -- c-addr u1 c-addr' u1' ) + .dword RtoP ; ( ... c-addr u1 c-addr' u1' u2 ) + .dword DECR ; ( ... c-addr u1 c-addr' u1' u2' ) + .dword DUP ; ( ... c-addr u1 c-addr' u1' u2' u2'' ) + .dword PtoR ; ( ... c-addr u1 c-addr' u1' u2' ) + .dword WLNUM ; ( ... c-addr u1 c-addr' u1' wid-addr ) + .dword FETCH ; ( ... c-addr u1 c-addr' u1' wid ) + .dword SEARCH_WORDLIST ; ( ... c-addr u1 0 | c-addr u1 xt +-1 ) + .dword QDUP ; ( ... c-addr u1 0 | c-addr u1 xt +-1 +-1 ) + .dword _IFFALSE ; ( ... c-addr u1 | c-addr u1 xt +-1 ) + .dword found + .dword RtoP ; ( ... c-addr u1 u2 ) + .dword DUP ; ( ... c-addr u1 u2 u2' ) + .dword _IFFALSE ; ( ... c-addr u1 u2 ) + .dword lp + .dword TWONIP ; ( ... u2 ) + EXIT +found: .dword RDROP + .dword TWOPtoR ; ( c-addr u1 xt +-1 -- c-addr u1 ) + .dword TWODROP ; ( c-addr u1 -- ) + .dword TWORtoP ; ( -- xt +-1 ) + EXIT +.endif +noorder: .dword FORTH_WORDLIST + .dword SEARCH_WORDLIST + EXIT +eword + +; H: ( c-addr u -- xn...x1 t | f ) environmental query +dword ENVIRONMENTQ,"ENVIRONMENT?" + ENTER + .dword dENVQ_WL + .dword SEARCH_WORDLIST + .dword DUP + .dword _IF + .dword nope + .dword DROP + .dword EXECUTE + .dword TRUE +nope: EXIT +eword + +; H: ( c-addr u -- xt true | c-addr u false ) find word in search order +dword dFIND,"$FIND" + ENTER + .dword TWODUP + .dword SEARCH_ALL + .dword DUP + .dword _IF + .dword notfnd + .dword DROP + .dword TWONIP + .dword TRUE ; IEEE 1275 requires true, not -1 or 1 +notfnd: EXIT +eword + +; H: ( c-addr -- xt ) find packed string word in search order, 0 if not found +dword FIND,"FIND" + ENTER + .dword DUP + .dword PtoR + .dword COUNT + .dword SEARCH_ALL + .dword DUP + .dword _IF + .dword notfd + .dword RDROP + EXIT +notfd: .dword RtoP + .dword SWAP + EXIT +eword + +; H: ( old-name<> -- xt ) parse old-name in input stream, return xt of word +dword PARSEFIND,"'" + ENTER + .dword PARSE_WORD + .dword SEARCH_ALL + .dword QDUP + .dword _IF + .dword exc + .dword DROP + EXIT +exc: ONLIT -13 + .dword THROW +eword + +; H: ( [old-name<>] -- xt ) immediately parse old-name in input stream, return xt of word +dword CPARSEFIND,"[']",F_IMMED + bra PARSEFIND::code +eword + +; H: ( xt -- a-addr) return body of word at xt, if unable then throw exception -31 +dword rBODY,">BODY" + jsr _popwr ; xt -> wr + ldy #$01 + lda [WR],y + and #$FF + cmp #opJSL + beq :+ + ldy #.loword(-31) + lda #.hiword(-31) + jmp _throway +: lda WR + clc + adc #$05 + tay + lda WR+2 + adc #$00 + PUSHNEXT +eword + +; H: ( a-addr -- xt ) return xt of word with body at a-addr, if unable throw exc. -31 +dword BODYr,"BODY>" + ENTER + ONLIT 1 + .dword CELLS + .dword MINUS + .dword DUP + .dword CFETCH + ONLIT opJSL + .dword EQUAL + .dword _IF + .dword bad + .dword DECR + EXIT +bad: ONLIT -31 + .dword THROW +eword + +; ( a-addr -- xt ) from link field address, return xt of word +hword drXT,"$>XT" + ENTER + .dword CELLPLUS + .dword DUP + .dword CFETCH + ONLIT NAMEMSK + .dword LAND + .dword PLUS + .dword CHARPLUS + EXIT +eword + +; ( xt -- xt f ) return immediacy of word at xt +hword IMMEDQ,"IMMED?" + jsr _peekwr + lda [WR] + and #F_IMMED +tf: beq :+ + lda #$FFFF +: tay + PUSHNEXT +eword + +; ( xt -- xt f ) return compile-only flag of word at xt +hword CONLYQ,"CONLY?" + jsr _peekwr + lda [WR] + and #F_CONLY + bra IMMEDQ::tf +eword + +; ( xt -- xt f ) return temp def flag of word at xt +; words with temp def flag will trigger a temporary definition to be created in order +; to run control-flow words in interpretation state +hword TEMPDQ,"TEMPD?" + jsr _peekwr + lda [WR] + and #F_TEMPD + bra IMMEDQ::tf +eword + +; needed by line editor +.proc _key + lda #SI_KEY + jsl _call_sysif + bcc :+ + jmp _throway +: rts +.endproc + +; H: ( -- char ) wait for input char, return it +dword KEY,"KEY" + jsr _key + NEXT +eword + +; H: ( -- f ) f = true if input char is ready, false otherwise +dword KEYQ,"KEY?" + lda #SI_KEYQ + jsl _call_sysif + bcc :+ + jmp _throway +: NEXT +eword + +; ( -- a-addr ) variable with address of terminal input buffer +hword dTIB,"$TIB" + SYSVAR SV_dTIB +eword + +; ( -- c-addr ) return address of terminal input buffer +hword TIB,"TIB" + ENTER + .dword dTIB + .dword FETCH + EXIT +eword + +; ( -- a-addr ) variable with address of current input buffer +hword dCIB,"$CIB" + SYSVAR SV_dCIB +eword + +; ( -- u ) variable with number of characters accepted by EXPECT +dword SPAN,"SPAN" + SYSVAR SV_SPAN +eword + +; TODO: add Open Firmware editing +; H: ( addr len -- u ) get input line of up to len chars, stor at addr, u = # chars accepted +dword ACCEPT,"ACCEPT" + clc +expect1: ror YR ; if YR high bit set, do auto-termination mode + jsr _popxr + jsr _popwr +inline: ldy #$00 ; entered length +getchar: phy + jsr _key + jsr _popay + tya + ply + cmp #c_bs ; basic editing functions + beq backspc + cmp #c_del + beq backspc + cmp #c_cr + beq done + cmp #' ' + bcc getchar ; ignore nonprintables + cpy XR ; if we are at max size already + bcs getchar ; then don't accept this char + sta [WR],y + phy + tay + jsr do_emit + ply + iny + cpy XR + bcc getchar +checkexp: bit YR ; in EXPECT mode? + bmi done ; yep, auto-terminate + bra getchar +backspc: cpy #$00 ; is line empty? + beq inline ; just start over if so + dey + phy ; otherwise do backspace & erase + ldy #c_bs + jsr do_emit + ldy #' ' + jsr do_emit + ldy #c_bs + jsr do_emit + ply + bra getchar +done: lda #$00 + jsr _pushay + bit YR + bmi expect2 + ENTER + JUMP docr +expect2: ENTER + .dword SPAN + .dword STORE +docr: .dword CR + EXIT +do_emit: jsr _pushay + jsr _emit + rts +eword + +; H: ( addr len -- ) get input line of up to len chars, stor at addr, actual len in SPAN +dword EXPECT,"EXPECT" + sec + jmp ACCEPT::expect1 +eword + +; ( -- ) set current input source to the keyboard/console +hword SETKBD,"SETKBD" + ENTER + .dword TIB + .dword dCIB + .dword STORE +dokbd: ONLIT 0 +doany: .dword dSOURCEID + .dword STORE + EXIT +eword + +; H: ( -- a-addr ) variable containing current input source ID +dword dSOURCEID,"$SOURCE-ID" + SYSVAR SV_SOURCEID +eword + +; H: ( -- n ) return current input source id (0 = console, -1 = string, >0 = file) +dword SOURCEID,"SOURCE-ID" + ldy #SV_SOURCEID + lda [SYSVARS],y + pha + iny + iny + lda [SYSVARS],y + ply + PUSHNEXT +eword + +; H: ( -- c-addr u ) return address and length of input source buffer +dword SOURCE,"SOURCE" + ENTER + .dword dCIB + .dword FETCH + .dword NIN + .dword FETCH + EXIT +eword + +; H: ( -- f ) refill input buffer, f = true if that worked, false if not +dword REFILL,"REFILL" + ENTER + .dword SOURCEID + .dword DUP + .dword _IFFALSE + .dword notkbd ; return false if input source isn't console + .dword PIN ; >IN, note zero is on the stack here + .dword STORE + .dword TIB + ONLIT tib_size + .dword ACCEPT + .dword NIN ; #IN + .dword STORE + .dword TRUE + EXIT +notkbd: .dword ZEROLT + .dword _IFFALSE ; is less than zero? + .dword noinput ; yes, go throw a false on the stack + SLIT "$REFILL" ; ( -- addr len true | false ) + .dword dFIND ; see if someone else handles it + .dword _IF ; $REFILL exists? + .dword noinput ; nope, nobody handles it + .dword EXECUTE ; otherwise, execute it and see what happens + .dword _IF ; that work out OK? + .dword noinput ; nope, just return false + .dword ZERO ; otherwise zero input pointer + .dword PIN + .dword STORE + .dword NIN ; set #IN to returned length + .dword STORE + .dword dCIB ; make it the input buffer + .dword STORE + EXIT +noinput: .dword FALSE + EXIT +eword + +; ( -- f ) f = true if there is remaining input in the input stream, false otherwise +hword INQ,"IN?" + ENTER + .dword PIN + .dword FETCH + .dword NIN + .dword FETCH + .dword ULT + EXIT +eword + +; ( -- c-addr ) return address of next character in input stream +hword INPTR,"INPTR" + ENTER + .dword PIN + .dword FETCH + .dword dCIB + .dword FETCH + .dword PLUS + EXIT +eword + +; ( -- ) increment >IN +hword INC_INPTR,"INPTR+" + ENTER + .dword ONE + .dword PIN + .dword PSTORE + EXIT +eword + +; ( -- char ) fetch char from input stream +hword GETCH,"GETCH" + ENTER + .dword INPTR + .dword CFETCH + .dword INC_INPTR + EXIT +eword + +hword tSTATUS,">STATUS" + ENTER + SLIT "STATUS" + .dword dFIND + EXIT +eword + +; ( -- ) call STATUS if defined, display OK (interpreting) or [OK] (compiling). +hword dSTATUS,"$STATUS" + ENTER + .dword SOURCEID + .dword ZEROQ + .dword _IF + .dword done ; do nothing if console is not source + .dword tSTATUS + .dword _IF + .dword nostatus + .dword EXECUTE + JUMP :+ +nostatus: .dword TWODROP +: .dword SPACE + .dword _SMART + .dword interp + SLIT "[OK]" + JUMP dprompt +interp: SLIT "OK" +dprompt: .dword TYPE + .dword CR +done: EXIT +eword + +; H: ( -- ) assuming STATUS is a defer, set it to .S +dword SHOWSTACK,"SHOWSTACK" + ENTER + ONLIT DOTS +set: .dword tSTATUS + .dword _IF + .dword nostatus + .dword rBODY + .dword STORE + EXIT +nostatus: .dword THREEDROP + EXIT +eword + +; H: ( -- ) assuming STATUS is a defer, set it to NOOP +dword NOSHOWSTACK,"NOSHOWSTACK" + ENTER + ONLIT NOOP + JUMP SHOWSTACK::set +eword + +; ( char -- ) see if char is a space (or unprintable) +hword ISSPC,"ISSPACE?" + ENTER + .dword BL + .dword INCR + .dword ULT + EXIT +eword + +; H: ( "word"<> -- c-addr u ) parse word from input stream, return address and length +dword PARSE_WORD,"PARSE-WORD" + ENTER +l1: .dword INQ ; is there input? + .dword _IF + .dword none ; nope, return empty + .dword GETCH ; get char + .dword ISSPC ; is space? + .dword _IFFALSE ; if not... + .dword l1 ; do loop if it is + .dword INPTR ; get address + .dword DECR ; fixup because INPTR is 1 ahead now + .dword ONE ; we have 1 char +l2: .dword INQ ; more input? + .dword _IF + .dword e1 ; if not, exit + .dword GETCH + .dword ISSPC + .dword _IFFALSE + .dword e1 ; yes, stop + .dword INCR ; count non-spaces + JUMP l2 +e1: EXIT +none: .dword INPTR + .dword ZERO + EXIT +eword + +; H: ( "word"<> -- c-addr u ) alias of PARSE-WORD +dword PARSE_NAME,"PARSE-NAME" + bra PARSE_WORD::code +eword + +; H: ( char "word" -- c-addr u ) parse word from input stream, delimited by char +dword PARSE,"PARSE" + ENTER + .dword PtoR + .dword INPTR + .dword ZERO +l1: .dword INQ + .dword _IF + .dword e1 + .dword GETCH + .dword RCOPY + .dword EQUAL + .dword _IF + .dword i1 +e1: .dword RDROP + EXIT +i1: .dword INCR + JUMP l1 +eword + +; H: ( char "word" -- c-addr ) parse word from input stream delimited by char, return +; H: address of WORD buffer containing packed string +dword WORD,"WORD" + ENTER + .dword PARSE + .dword DUP + ONLIT word_buf_size + .dword ULT + .dword _IF + .dword bad + .dword WORDBUF + .dword PACK + EXIT +bad: ONLIT -18 + .dword THROW +eword + +; H: ( "word"<> -- char ) parse word from input stream, return value of first char +dword CHAR,"CHAR" + ENTER +do: .dword PARSE_WORD + .dword DROP + .dword CFETCH + EXIT +eword + +; H: ( "word"<> -- char ) immediately perform CHAR and compile literal +dword CCHAR,"[CHAR]",F_IMMED|F_CONLY + ENTER +do: .dword CHAR + .dword LITERAL + EXIT +eword + +; H: ( "word"<> -- char ) perform either CHAR or [CHAR] per the current compile state +dword ASCII,"ASCII",F_IMMED + ENTER + .dword _SMART + .dword CHAR::do + JUMP CCHAR::do +eword + +; H: ( "text" -- ) parse and discard text until a right paren or end of input +dword LPAREN,"(",F_IMMED + ENTER + ONLIT ')' + .dword PARSE + .dword TWODROP + EXIT +eword + +; H: ( "text" -- ) parse text until a right paren or end of input, output text +dword DOTPAREN,".(",F_IMMED + ENTER + ONLIT ')' + .dword PARSE + .dword TYPE + EXIT +eword + +; Helper to compile a string +; ( c-addr u -- ) +hword CSTRING,"CSTRING" + jsr _2parm + ldy #.loword(docs-1) + lda #.hiword(docs-1) + jsr _str_op_ays + NEXT +docs: jsr _cbytea + clc + rtl +eword + +; compile string literal as described by top two stack items +; H: C: ( c-addr1 u -- ) R: ( -- c-addr 2 u ) compile string literal into current def +dword SLITERAL,"SLITERAL",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT + .dword _SLIT + .dword DUP + .dword COMPILECOMMA + .dword CSTRING + EXIT +eword + +; H: ( "text"<"> -- c-addr u ) +dwordq SQ,"S'",F_IMMED + ENTER + ONLIT '"' + .dword PARSE + .dword _SMART + .dword interp + .dword SLITERAL + EXIT +interp: .dword dTMPSTR + EXIT +eword + +; H: ( "text"<"> -- ) output parsed text +dwordq DOTQ,".'",F_IMMED + ENTER + .dword SQ + .dword _SMART + .dword interp + .dword _COMP_LIT +interp: .dword TYPE + EXIT +eword + +; parse paired hex digits until right paren +; return string in buffer created by alloc-mem +; H: ( "text" -- c-addr u ) parse hex, return in allocated string +dword dHEXP,"$HEX(",F_IMMED + ENTER + ONLIT 256 + .dword ALLOC + ONLIT ')' + .dword PARSE + CODE + jsr _popxr ; length of parsed string + jsr _popwr ; address of parsed string + jsr _popyr ; address of allocated buffer + stz XR+2 ; will count how many digits we have stuffed + ldy #$00 ; will count the source chars processed +lp: cpy XR + beq done + sep #SHORT_A + lda [WR],y + rep #SHORT_A + and #$FF + jsr _c_to_d + bcc next ; invalid digit + cmp #$10 + bcs next ; bigger than a hex digit + phy ; save index + pha ; save digit + lda XR+2 + inc XR+2 + lsr + tay + pla + bcc store ; even digits (from 0) just need to store +odd: sep #SHORT_A ; odd digits shift into the low nibble + asl ; C 000d => 00d0 + asl + asl + asl + xba ; C 00d0 => d000 + lda [YR],y ; C d000 => d00e + xba ; C d00e => 0ed0 + rep #SHORT_A + lsr + lsr + lsr + lsr +store: sep #SHORT_A + sta [YR],y + rep #SHORT_A + ply ; get counter back +next: iny + bra lp +done: ldy YR + lda YR+2 + jsr _pushay + lda XR+2 ; # of digits + lsr ; convert to # chars + adc #$00 ; if odd, round up + tay + lda #$00 + PUSHNEXT +eword + +; ( c-addr1 u1 c-addr2 u2 -- caddr1 u1+u2 ) +; c-addr1 is assumed to have enough room for the string +hword SCONCAT,"SCONCAT" + jsr _4parm + lda STACKBASE+12,x ; get c-addr1+u1 to YR + clc + adc STACKBASE+8,x + sta YR + lda STACKBASE+14,x + adc STACKBASE+10,x + sta YR+2 + jsr _popxr ; u2 to xr + jsr _popwr ; c-addr2 to WR + lda XR + clc + adc STACKBASE+0,x ; make u1+u2 + sta STACKBASE+0,x + lda XR+2 + adc STACKBASE+2,x + sta STACKBASE+2,x + jsr _move ; move the string + NEXT +eword + +; H: ( "text"<"> -- c-addr u ) parse quoted text in input buffer, copy to allocated string +dwordq ASTR,"A'" + ENTER + ONLIT '"' + .dword PARSE + .dword DUP + .dword ALLOC + .dword ZERO + .dword TWOSWAP + .dword SCONCAT + EXIT +eword + +; H: ( c-addr1 u1 c-addr2 u2 -- c-addr3 u1+u2 ) concatenate allocated strings +; Concatenate two strings that are in memory returned by ALLOC-MEM +; returning a string allocated via ALLOC-MEM and the original strings +; freed via FREE-MEM +dword ACONCAT,"ACONCAT" + ENTER + .dword TWOPtoR ; ( c-addr1 u1 c-addr2 u2 -- c-addr u1 ) save second string + .dword DUP ; ( ... c-addr1 u1 u1' ) copy u1 + .dword RCOPY ; ( ... c-addr1 u1 u1' u2' ) get a copy of u2 + .dword PLUS ; ( ... c-addr1 u1 u3 )sum them to get u1+u2 + .dword ALLOC ; ( ... c-addr1 u1 c-addr3 ) allocate that many + ONLIT 0 ; ( ... c-addr1 u1 c-addr3 0 ) say it's zero length + .dword TWOSWAP ; ( ... c-addr3 0 c-addr1 u1 ) put it at the front + .dword OVER ; ( ... c-addr3 0 c-addr1 u1 c-addr1' )copy c-addr1 + .dword PtoR ; ( ... c-addr3 0 c-addr1 u1 ) save for FREE-MEM + .dword SCONCAT ; ( ... c-addr3 u1 ) copy first string + .dword RtoP ; ( ... c-addr3 u1 c-addr1 ) + ONLIT 0 + .dword FREE ; ( ... c-addr3 u1 ) free it + .dword TWORtoP ; ( ... c-addr3 u1 c-addr2 u2 ) + .dword OVER ; ( ... c-addr3 u1 c-addr2 u2 c-addr2' ) + .dword PtoR ; ( ... c-addr3 u1 c-addr2 u2 ) + .dword SCONCAT ; ( ... c-addr3 u1+u2 ) + .dword RtoP ; ( ... c-addr3 u1+u2 c-addr2 ) + ONLIT 0 + .dword FREE ; ( ... c-addr3 u1+u2 ) + EXIT +eword + +; H: ( "text"<"> -- c-addr u ) parse string, including hex interpolation +dwordq QUOTE,"'",F_IMMED + ENTER + .dword ZERO ; ( -- 0 ) + .dword ALLOC ; ( 0 -- c-addr1 ) empty allocation + .dword ZERO ; ( c-addr1 -- c-addr1 0 ) +moretext: .dword ASTR ; ( c-addr1 u1 -- c-addr1 u1 c-addr2 u2 ) + .dword ACONCAT ; ( ... c-addr3 u3 ) + .dword INQ ; ( ... c-addr3 u3 f ) + .dword _IF ; ( ... c-addr3 u3 ) + .dword finish ; no more text to parse, finish up + .dword GETCH ; ( ... c-addr3 u3 c ) + .dword DUP ; ( ... c-addr3 u3 c c' ) + .dword ISSPC ; ( ... c-addr3 u3 c f ) + .dword _IFFALSE ; ( ... c-addr3 u3 c ) + .dword space ; is a space, drop space and return string + ONLIT '(' ; ( ... c-addr3 u3 c '(' ) + .dword EQUAL ; ( ... c-addr3 u3 f ) + .dword _IF ; ( ... c-addr3 u3 ) + .dword finish ; finish, but we will probably error later in parsing + .dword dHEXP ; ( ... c-addr3 u3 c-addr4 u4 ) + .dword ACONCAT ; ( ... c-addr5 u5 ) + JUMP moretext ; and switch back to parsing quoted string +space: .dword DROP +finish: .dword OVER ; ( c-addr3 u3 -- c-addr3 u3 c-addr3' ) + .dword PtoR ; ( ... c-addr3 u3 ) ( R: -- c-addr3' ) + .dword _SMART + .dword interp + .dword SLITERAL ; ( c-addr3 u3 -- ) + JUMP done +interp: .dword dTMPSTR +done: .dword RtoP ; ( -- c-addr3' ) ( R: c-addr3' -- ) + ONLIT 0 + .dword FREE ; ( c-addr3' -- ) + EXIT +eword + +; H: ( -- ) Compile code to compile the immediately following xt. Better to use POSTPONE. +; BTW don't use with numbers. +dword COMPILE,"COMPILE",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT ; Compile a _COMP_LIT + .dword _COMP_LIT + EXIT +eword + +; H: ( "name"<> -- ) Compile name later. Better to use postpone. +dword ICOMPILE,"[COMPILE]",F_IMMED + ENTER + .dword PARSEFIND + .dword COMPILECOMMA + EXIT +eword + +; H: ( "name"<> -- ) +; Compile the compilation semantics of name +; Basically, if the word is immediate, compile its xt +; If not, compile code that compiles its xt +dword POSTPONE,"POSTPONE",F_IMMED + ENTER + .dword PARSE_WORD + .dword SEARCH_ALL + .dword QDUP + .dword _IF + .dword exc + .dword ZEROLT + .dword _IF + .dword immed ; if >0, it is an IMMEDIATE word, go compile xt + .dword LITERAL ; compile its xt as a literal + .dword _COMP_LIT ; and compile COMPILE, +immed: .dword COMPILECOMMA + EXIT +exc: ONLIT -13 + .dword THROW +eword + +; H: ( -- ) output the words in the CONTEXT wordlist +dword WORDS,"WORDS" + ENTER + .dword CONTEXT + .dword FETCH +lp: .dword DUP ; ( h -- h h ) + .dword _IF ; ( h h -- h ) + .dword done + .dword DUP ; ( h -- h h ) + .dword drXT ; ( h -- h xt ) + .dword DUP ; ( h xt -- h xt xt ) + .dword UDOT ; ( h xt xt -- h xt ) + .dword rNAME ; ( h xt -- h c-addr u ) + .dword TYPE ; ( h c-addr u -- h ) + .dword CR + .dword EXITQ ; ( h -- h f ) + .dword _IFFALSE + .dword done + .dword FETCH ; ( h -- h' ) + JUMP lp +done: .dword DROP ; ( h -- ) + EXIT +eword + +.if include_see +; H: ( xt -- ) attempt to decompile the word at xt +dword dSEE,"(SEE)" + ENTER + .dword QDUP + .dword _IF + .dword notxt + SLIT "Flags: " ; ( xt -- xt str len ) + .dword TYPE ; ( str len -- ) + .dword DUP ; ( xt -- xt xt' ) + .dword CFETCH ; ( xt xt' -- xt u ) + .dword UDOT ; ( xt u -- xt ) + .dword CR + .dword DUP ; ( xt -- xt xt' ) + .dword rNAME ; ( xt xt' -- xt str len ) + .dword ROT ; ( xt str len -- str len xt ) + .dword INCR ; ( str len xt -- str len a-addr ) + .dword DUP ; ( ... str len a-addr a-addr' ) + .dword FETCH ; ( ... str len a-addr u ) + ONLIT (_enter << 8)+opJSL ; ( ... str len a-addr u x ) + .dword EQUAL ; ( ... str len a-addr f ) + .dword _IF ; ( ... str len a-addr ) + .dword cant + ONLIT ':' ; ( ... str len a-addr ':' ) + .dword EMIT ; ( ... str len a-addr ) + .dword SPACE + .dword NROT ; ( ... a-addr str len ) + .dword TYPE ; ( ... a-addr ) + .dword CR +lp: .dword CELLPLUS ; ( a-addr(old) -- a-addr ) + .dword DUP ; ( ... a-addr a-addr' ) + .dword FETCH ; ( ... a-addr u ) + ONLIT _exit_next-1 + .dword _IFEQUAL + .dword :+ + .dword DROP + ONLIT ';' + .dword EMIT +quit: .dword DROP +notxt: EXIT +: .dword OVER ; ( ... a-addr u a-addr' ) + .dword UDOT ; ( ... a-addr u ) + ONLIT _LIT + .dword _IFEQUAL + .dword :+ + .dword DROP + .dword CELLPLUS + .dword DUP + .dword FETCH + .dword DOT + JUMP crlp +: ONLIT _WLIT + .dword _IFEQUAL + .dword :+ + .dword DROP + .dword CELLPLUS + .dword DUP + .dword WFETCH + .dword DOT + .dword TWODECR + JUMP crlp +: ONLIT _CLIT + .dword _IFEQUAL + .dword :+ + .dword DROP + .dword CELLPLUS + .dword DUP + .dword CFETCH + .dword DOT + .dword THREE + .dword MINUS + JUMP crlp +: ONLIT _SLIT + .dword _IFEQUAL + .dword :+ + .dword DROP ; ( ... a-addr ) + .dword CELLPLUS ; skip _SLIT + .dword DUP + .dword FETCH ; ( ... a-addr len ) get length of string + .dword SWAP ; ( ... len a-addr ) + ;.dword CELLPLUS ; ( ... len a-addr ) + .dword TWODUP ; ( ... len a-addr len a-addr ) + .dword CELLPLUS + .dword SWAP ; ( ... len a-addr a-addr len ) + ONLIT '"' + .dword EMIT + .dword TYPE ; ( ... len a-addr ) + ONLIT '"' + .dword EMIT + .dword PLUS + JUMP crlp +: .dword rNAME ; ( ... a-addr str len ) + .dword TYPE ; ( ... a-addr ) +crlp: .dword CR + .dword EXITQ ; ( ... a-addr f ) + .dword _IFFALSE ; ( ... a-addr ) + .dword quit + JUMP lp +cant: .dword DROP ; drop pointer + SLIT "Can't see " + .dword TYPE + .dword TYPE + EXIT +eword + +; H: ( "name"<> -- ) attempt to decompile name +dword SEE,"SEE" + ENTER + .dword PARSEFIND + .dword dSEE + EXIT +eword +.endif + +; H: ( c-addr u -- ) like CREATE but use c-addr u for name +dword dCREATE,"$CREATE" + jsr _mkentry +docreate: ldy #.loword(_pushda) + lda #.hiword(_pushda) + jsr _cjsl + NEXT +eword + +; H: ( "name"<> -- ) create a definition, when executed pushes the body address +dword CREATE,"CREATE" + ENTER + .dword PARSE_WORD + .dword dCREATE + EXIT +eword + +; H: ( "name"<> -- ) execute CREATE name and ALLOT one cell, initially a zero. +dword VARIABLE,"VARIABLE" + ENTER + .dword CREATE + .dword ZERO + .dword COMMA + EXIT +eword + +; action of DOES +; modify the most recent definition (CREATED) to jsl to the address immediately +; following whoever JSLed to this and return to caller +.proc _does + ENTER + .dword LAST + .dword drXT + .dword INCR + CODE + jsr _popyr + pla + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$00FF + sta WR+2 + jsr _incwr + ldy #$00 + lda [YR],y + and #$00FF + cmp #opJSL + bne csmm + lda WR + iny + sta [YR],y + lda WR+2 + iny + iny + sep #SHORT_A + sta [YR],y + rep #SHORT_A + NEXT +csmm: jmp _CONTROL_MM::code +.endproc + +; H: ( -- ) alter execution semantics of most recently-created definition to perform +; H: the following execution semantics. +dword DOES,"DOES>",F_IMMED|F_CONLY + ENTER + .dword SEMIS + .dword _COMP_LIT + jsl f:_does ; better be 4 bytes! + .dword _COMP_LIT + ENTER ; not really, now + .dword _COMP_LIT + .dword RPLUCKADDR + .dword _COMP_LIT + .dword INCR + .dword STATEC ; ensure still in compiling state + EXIT +eword + +; ( -- ) throw exception -13 +hword dUNDEFERRED,"$UNDEFERRED" + ldy #.loword(-13) + lda #.hiword(-13) + jmp _throway +eword + +; ( xt str len -- ) -- create a deferred word with xt as its initial behavior +hword dDEFER,"$DEFER" + jsr _3parm + jsr _mkentry +dodefer: ldy #.loword(_deferred) + lda #.hiword(_deferred) + jsr _cjsl + jsr _popay + jsr _ccellay + NEXT +eword + +; H: ( "name"<> -- ) create definition that executes the first word of the body as an xt +dword DEFER,"DEFER" + ENTER + NLIT dUNDEFERRED + .dword PARSE_WORD + .dword dDEFER + EXIT +eword + +; H: ( "name"<> -- ) return the first cell of the body of name, which should be a DEFER word +dword BEHAVIOR,"BEHAVIOR" + ENTER + .dword rBODY + .dword FETCH + EXIT +eword + +; H: ( str len xt -- ) create a DEFER definition for string with xt as its initial behavior +dword IS_USER_WORD,"(IS-USER-WORD)" + ENTER + .dword NROT ; reorder for $DEFER + .dword dDEFER + EXIT +eword + +; H: ( n str len ) create a definition that pushes the first cell of the body, initially n +dword dVALUE,"$VALUE" + jsr _3parm ; avoid dictionary corruption from stack underflow + jsr _mkentry +dovalue: ldy #.loword(_pushvalue) + lda #.hiword(_pushvalue) + jsr _cjsl + jsr _popay + jsr _ccellay + NEXT +eword + +; H: ( n1 n2 str len ) create a definition that pushes the first two cells of the body +; H: initially n1 and n2 +dword dTWOVALUE,"$2VALUE" + jsr _4parm ; avoid dictionary corruption from stack underflow + jsr _mkentry + ldy #.loword(_push2value) + lda #.hiword(_push2value) + jsr _cjsl + jsr _popay + jsr _ccellay + jsr _popay + jsr _ccellay + NEXT +eword + +; H: ( n "name"<> -- ) create a definition that pushes n on the stack, n can be changed +; H: with TO +dword VALUE,"VALUE" + ENTER + .dword PARSE_WORD + .dword dVALUE + EXIT +eword + +; H: ( n -- ) allocate memory immediately, create definition that returns address of memory +dword BUFFERC,"BUFFER:" + ENTER + .dword ALLOC + .dword VALUE + EXIT +eword + +; H: ( n "name"<> -- ) alias of VALUE, OF816 doesn't have true constants +; we don't have real constants, they can be modified with TO +dword CONSTANT,"CONSTANT" + bra VALUE::code +eword + +; FCode support, these are needed to support the INSTANCE feature when it is installed +; and so are included in the main dictionary. By default the FCodes for b(value), +; b(buffer), b(variable), and b(defer) point to these. When the INSTANCE feature +; is installed, it will call set-token to replace these, but will still need to call them +; in the case that INSTANCE was not used. +.if include_fcode +; ( -- ) compile the machine execution semantics of CREATE (jsl _pushda) +hword pCREATE,"%CREATE" + jmp dCREATE::docreate +eword + +; H: ( n -- ) compile the machine execution semantics of VALUE (jsl _pushvalue) and the value +dword pVALUE,"%VALUE" + jsr _1parm + jmp dVALUE::dovalue +eword + +; H: ( n -- ) compile the machine execution semantics of BUFFER (jsl _valuevalue) and the +; H: buffer address +dword pBUFFER,"%BUFFER" + ENTER + .dword ALLOC + .dword pVALUE + EXIT +eword + +; H: ( -- ) compile the machine execution semantics of CREATE (jsl _pushda) and compile a zero +dword pVARIABLE,"%VARIABLE" + ENTER + .dword pCREATE + .dword ZERO + .dword COMMA + EXIT +eword + +; H: ( -- ) compile the machine execution semantics of DEFER (jsl _deferred) +dword pDEFER,"%DEFER" + ldy #.loword(dUNDEFERRED) + lda #.hiword(dUNDEFERRED) + jsr _pushay + jmp dDEFER::dodefer +eword +.endif + +; H: ( n1 n2 "name"<> -- ) create name, name does ( -- n1 n2 ) when executed +dword TWOCONSTANT,"2CONSTANT" + ENTER + .dword PARSE_WORD + .dword dTWOVALUE + EXIT +eword + +; H: ( "name1"<> "name2"<> -- ) create name1, name1 is a synonym for name2 +dword ALIAS,"ALIAS" + ENTER + .dword PARSE_WORD + .dword PARSEFIND + .dword INCR + .dword NROT + CODE + jsr _mkentry + jsr _popay + jsr _cjml + NEXT +eword + +; ( n xt -- ) change the first cell of the body of xt to n +hword _TO,"_TO" + ENTER + .dword rBODY + .dword STORE + EXIT +eword + +; H: ( n "name"<> -- ) change the first cell of the body of xt to n. Can be used on +; most words created with CREATE, DEFER, VALUE, etc. even VARIABLE +dword TO,"TO",F_IMMED + ENTER + .dword PARSEFIND +doto: .dword _SMART + .dword setval + .dword LITERAL + .dword _COMP_LIT +setval: .dword _TO + EXIT +eword + +; H: ( -- 0 ) +dword STRUCT,"STRUCT" + lda #$0000 + tay + PUSHNEXT +eword + +; ( offset size c-addr u -- offset+size ) create word specified by c-addr u with +; execution semantics: ( addr -- addr+offset) +hword dFIELD,"$FIELD" + jsr _4parm + jsr _mkentry +dofield: ldy #.loword(_field) + lda #.hiword(_field) + jsr _cjsl + ldy STACKBASE+4,x + lda STACKBASE+6,x + jsr _ccellay + lda STACKBASE+0,x + clc + adc STACKBASE+4,x + sta STACKBASE+4,x + lda STACKBASE+2,x + adc STACKBASE+6,x + sta STACKBASE+6,x + jsr _stackincr + NEXT +eword + +; H: ( offset size "name"<> -- offset+size ) create name, name exec: ( addr -- addr+offset) +dword FIELD,"FIELD" + ENTER + .dword PARSE_WORD + .dword dFIELD + EXIT +eword + +; ( str len -- xt ) define word with empty execution semantics +hword dDEFWORD,"$DEFWORD" + ldy #SV_OLDHERE + lda DHERE + sta [SYSVARS],y + iny + iny + lda DHERE+2 + sta [SYSVARS],y + jsr _mkentry + jsr _pushay ; flags/XT + NEXT +eword + +; ( -- ) compile colon definition execution semantics (JSL _enter) +hword dCOLON,"$COLON" + ldy #.loword(_enter) + lda #.hiword(_enter) + jsr _cjsl + NEXT +eword + +; ( xt -- ) hide visibility of definition at xt +hword SMUDGE,"SMUDGE" + ENTER + .dword DUP ; dup XT (flags addr) + .dword CFETCH ; so we can smudge it + ONLIT F_SMUDG + .dword LOR + .dword SWAP + .dword CSTORE + EXIT +eword + +; H: ( "name"<> -- colon-sys ) parse name, create colon definition and enter compiling state +dword COLON,":" + ENTER + .dword PARSE_WORD + .dword dDEFWORD + .dword dCOLON + .dword DUP ; one for setting flags, one for colon-sys + .dword SMUDGE + .dword DUP ; and one for RECURSE + .dword dCURDEF + .dword STORE + .dword STATEC + EXIT +eword + +; H: ( -- colon-sys ) create an anonymous colon definition and enter compiling state +; H: the xt of the anonymous definition is left on the stack after ; +dword NONAME,":NONAME" + ENTER + ONLIT $80 ; name length is 0 for noname + .dword CCOMMA + .dword HERE ; XT/flags + .dword DUP ; one for user, one for colon-sys + .dword DUP ; and one for RECURSE + .dword dCURDEF + .dword STORE + ONLIT $00 ; noname flags + .dword CCOMMA + .dword STATEC + .dword dCOLON + EXIT +eword + +; H: ( -- colon-sys ) create a temporary anonymous colon definition and enter compiling state +; H: the temporary definition is executed immediately after ; +; word supporting temporary colon definitions to implement IEEE 1275 +; words that are extended to run in interpretation state +dword dTEMPCOLON,":TEMP" + ENTER + ;SLIT "Starting temp def... " + ;.dword TYPE + ONLIT max_tempdef ; allocate 128 cells worth of tempdef + .dword ALLOC + .dword DUP + .dword dTMPDEF ; and save its allocation + .dword STORE + .dword HERE ; save HERE + .dword dSAVEHERE + .dword STORE + .dword toHERE ; and then set it to the temp def allocation + .dword NONAME ; start anonymous definition + .dword DEPTH ; save stack depth (data stack is control stack) + .dword dCSDEPTH + .dword STORE + EXIT +eword + +; word to end temporary colon definition and run it +; ( xt xt' -- ) +hword dTEMPSEMI,"$;TEMP",F_IMMED|F_CONLY + ENTER + .dword dTMPDEF ; ( -- a-addr ) + .dword FETCH ; ( a-addr -- c-addr ) 0 if not in temp def + .dword _IF ; ( c-addr -- ) + .dword csmm ; something is wrong +dosemi: .dword DEPTH ; ( -- u1 ) + .dword dCSDEPTH ; ( u1 -- u1 c-addr1 ) verify stack depth is what it should be + .dword FETCH ; ( u1 c-addr1 -- u1 u2 ) + .dword ULTE ; ( u1 u2 -- f ) is less than or equal to? + .dword _IFFALSE ; ( f -- ) + .dword tmpdone ; true branch, finish up temp def + .dword TWODROP + EXIT +tmpdone: ;SLIT "Ending temp def... " + ;.dword TYPE + .dword DEPTH ; ( -- u1 ) + .dword dCSDEPTH ; ( u1 -- u1 c-addr1 ) verify stack depth is what it should be + .dword FETCH ; ( u1 c-addr1 -- u1 u2 ) + .dword EQUAL ; ( u1 u2 -- f ) + .dword _IF ; ( f -- ) + .dword csmm ; if not, we have a problem + .dword _COMP_LIT ; compile EXIT into temporary def + EXIT ; NOTE: not really EXITing here + .dword STATEI ; ( -- ) + .dword dSAVEHERE ; ( -- a-addr ) restore HERE + .dword FETCH ; ( a-addr -- c-addr ) + .dword toHERE ; ( c-addr -- ) + .dword dTMPDEF ; ( -- a-addr ) get location of temporary definition + .dword DUP ; ( -- a-addr a-addr' ) one for FREE, one to write zero into it + .dword FETCH ; ( a-addr a-addr' -- a-addr c-addr ) + .dword PtoR ; ( a-addr c-addr -- a-addr ) ( R: -- c-addr ) safe for FREE + .dword OFF ; ( a-addr -- ) zero $TEMPDEF + .dword DROP ; ( xt xt -- xt ) now we worry about ( xt xt ) consume colon-sys + .dword CATCH ; ( xt -- * r ) execute the temporary definition within catch + .dword RtoP ; ( r -- r c-addr ) ( R: c-addr -- ) +dofree: ONLIT max_tempdef ; ( r c-addr -- r c-addr u ) + .dword FREE ; ( r c-addr u -- r ) + .dword THROW ; ( r -- ) re-throw any error in temp def + EXIT +csmm: .dword STATEI ; ( -- ) + .dword dSAVEHERE ; ( -- a-addr ) restore HERE + .dword FETCH ; ( a-addr -- c-addr ) + .dword toHERE ; ( c-addr -- ) + ONLIT -22 ; ( -- -22 ) will be thrown + .dword dTMPDEF ; ( -22 -- -22 c-addr ) + JUMP dofree +eword + +; Maybe close temporary definition +hword dTEMPSEMIQ,"$;TEMP?" + ENTER + .dword dTMPDEF + .dword FETCH + .dword _IFFALSE + .dword dTEMPSEMI::dosemi ; we are doing a temp def, maybe close and run + EXIT +eword + +; ( xt -- ) make definition at xt visible +hword UNSMUDGE,"UNSMUDGE" + ENTER + .dword DUP ; dup XT (flags addr) + .dword CFETCH ; so we can unsmudge it + ONLIT F_SMUDG + .dword INVERT + .dword LAND + .dword SWAP + .dword CSTORE + EXIT +eword + +; H: ( colon-sys -- ) consume colon-sys and enter interpretation state, ending the current +; H: definition. If the definition was temporary, execute it. +dword SEMI,";",F_IMMED|F_CONLY + ENTER + .dword dTMPDEF ; see if it's a temporary definition + .dword FETCH + .dword _IF + .dword :+ + .dword dTEMPSEMI ; if it is, do that instead + EXIT +: .dword _COMP_LIT ; compile EXIT into current def + EXIT ; NOTE: not really EXITing here +dosemi: .dword UNSMUDGE ; consume colon-sys + .dword STATEI ; exit compilation state + ONLIT 0 + .dword dOLDHERE + .dword STORE + EXIT +eword + +; H: ( -- ) make the current definition findable during compilation +dword RECURSIVE,"RECURSIVE",F_IMMED|F_CONLY + ENTER + .dword dCURDEF + .dword FETCH + .dword UNSMUDGE + EXIT +eword + +; H: ( -- ) compile the execution semantics of the most recently-created definition +dword RECURSE,"RECURSE",F_IMMED|F_CONLY + ENTER + .dword dCURDEF + .dword FETCH + .dword COMPILECOMMA + EXIT +eword + +; H: ( "name"<> -- code-sys ) create a new CODE definiion +; TODO: activate ASSEMBLER words if available +dword CODEDEF,"CODE" + ENTER + .dword PARSE_WORD + .dword dDEFWORD +docode: .dword DUP ; one for setting flags, one for colon-sys + .dword SMUDGE + ; .dword STATEC + EXIT +eword + +; H: ( "name"<> -- code-sys ) create a new LABEL definition +dword LABEL,"LABEL" + ENTER + .dword PARSE_WORD + .dword dCREATE + .dword LAST + .dword drXT + JUMP CODEDEF::docode +eword + +; H: ( code-sys -- ) consume code-sys, end CODE or LABEL definition +dword CSEMI,"C;" + jsr _1parm + ldy #.loword(_next) + lda #.hiword(_next) + jsr _cjml + ENTER + JUMP SEMI::dosemi +eword + +; H: ( code-sys -- ) synonym for C; +dword ENDCODE,"END-CODE",F_IMMED|F_CONLY + bra CSEMI::code +eword + +; ( xt -- ) mark XT as immediate +hword dIMMEDIATE,"$IMMEDIATE" + ENTER + .dword DUP ; dup XT (flags addr) + .dword CFETCH + ONLIT F_IMMED + .dword LOR + .dword SWAP + .dword CSTORE + EXIT +eword + +; H: ( -- ) mark last compiled word as an immediate word +dword IMMEDIATE,"IMMEDIATE" + ENTER + .dword LAST + .dword drXT + .dword dIMMEDIATE + EXIT +eword + +; ( xt -- ) mark word at xt as protected +hword dPROTECTED,"$PROTECTED" + ENTER + .dword DUP ; dup XT (flags addr) + .dword CFETCH + ONLIT F_PROT + .dword LOR + .dword SWAP + .dword CSTORE + EXIT +eword + +; ( -- ) mark last created word as protected (e.g. from FORGET) +hword PROTECTED,"PROTECTED" + ENTER + .dword LAST + .dword drXT + .dword dPROTECTED + EXIT +eword + +; ( -- ) for DOES> and ;CODE +hword SEMIS,"SEMIS" + ENTER + .dword _COMP_LIT + CODE ; not really, see NOTE above + .dword RECURSIVE ; allow word to be found + EXIT +eword + +; TODO attempt to activate assembler package +; H: ( -- ) end compiler mode, begin machine code section of definition +dword SCODE,";CODE",F_IMMED|F_CONLY + bra SEMIS::code +eword + +.if 0 +; ANS Forth locals + +; ( u -- ) ( R: -- old_locals_ptr u*0 u2 ) +; u2 = old SP after +hword dCREATE_LOCALS,"$CREATE-LOCALS" + lda locals_ptr ; current locals pointer (in stack) + pha ; save it + tsc ; current stack pointer (for fast cleanup) + sta WR ; save for now + jsr _popay ; get number of locals + lda #$0000 ; gonna zero them all out +lp: dey + bmi done + pha ; for each local, throw a cell on the stack + pha + bra lp +done: tsc ; now set up locals pointer to new block of locals + inc a ; 'cause '02 stack ptr is at the free byte + sta locals_ptr + lda WR + pha + NEXT +eword + +; ( u -- ) ( R: u*n -- ) +hword dDESTROY_LOCALS,"$DESTROY-LOCALS" + pla ; this is the old SP after saved locals poubter + tcs ; restore return stack + pla ; get old locals pointer + sta locals_ptr ; and make it current +eword + + +; ( u -- ) common routine to set up WR and Y register to access a local by number +.proc _localcom + lda locals_ptr ; get current locals pointer + sta WR ; set up WR to point to it + stz WR+2 + jsr _popay ; get local number + tya ; and compute offset into locals + asl + tay + rts +.endproc + +; ( u -- n ) fetch from local +hword dLOCALFETCH,"$LOCAL@" + jsr _localcom ; set up WR and Y reg + lda [WR],y ; low byte + pha ; save for now + iny ; move to high byte + iny + lda [WR],y ; get it + ply ; get low byte back + PUSHNEXT ; and toss on stack +eword + +; ( n u -- ) +hword dLOCALSTORE,"$LOCAL!" + jsr _swap ; get value to top + jsr _popay ; and put on return stack for now + pha + phy + jsr _localcom ; set up WR and Y reg + pla ; get low byte of value back + sta [WR],y ; store it + iny ; move to high byte + iny + pla ; get it back + sta [WR],y ; and store + NEXT +eword + +.endif + +.if enable_quotations +; Quotations enable syntax as follows: +; during compilation: [: ( -- quot-sys ) ... ;] ( quot-sys -- ) define a quotation +; (anonymous def within a definition) +; run time: ( -- xt ) leave xt of the quotation on the stack +; note that SEE cannot decode words with quotations. +; This implementation skips the quotation with AHEAD and afterwards leaves the +; the xt on the stack. +; quot-sys is ( -- old-$CURDEF forward-ref xt ) +dword SQUOT,"[:",F_IMMED|F_CONLY + ENTER + .dword dCURDEF ; fix current def to quotation + .dword FETCH ; save current def for RECURSE + .dword AHEAD ; leaves address to resolve later + .dword NONAME ; start an anonymous definition + .dword DROP ; leave only one copy + EXIT +eword + +dword EQUOT,";]",F_IMMED|F_CONLY + ENTER + .dword _COMP_LIT ; compile EXIT into current def + EXIT ; NOTE: not really EXITing here + .dword SWAP ; put ahead target on top + .dword THEN ; resolve AHEAD + .dword LITERAL ; consume XT of word, place on stack at run-time + .dword dCURDEF ; restore current def to parent + .dword STORE ; and consume that + EXIT +eword +.endif + + +.if max_search_order > 0 + +; ( -- wid ) +; ( root -- wid ) create a wordlist rooted at root +hword dCREATE_WL,"$CREATE-WL" + ENTER + .dword HERE ; WID + .dword SWAP + .dword COMMA ; compile pointer to root + .dword _COMP_LIT + .dword 0 ; pointer to xt of vocabulary def, none in this case + EXIT +eword + +; H: ( -- wid ) create a new wordlist +; wordlists are allocated from the dictionary space, containing two cells +; the first being the last word defined in the wordlist, and the second containing +; an xt to an associated vocabulary definition if one has been defined +; the wid is the pointer to the first cell +dword WORDLIST,"WORDLIST" + ENTER + ONLIT H_FORTH ; root of all dictionaries + .dword dCREATE_WL + .dword 0 + EXIT +eword + +; H: ( -- wid ) create a new empty wordlist (danger!) +; non-standard method to create a completely empty wordlist. If this is the only +; list in the search order, it may be impossible to get out of the situation +dword dEMPTY_WL,"$EMPTY-WL" + ENTER + .dword ZERO ; null root + .dword dCREATE_WL + EXIT +eword + +; H: ( "name"<> -- ) create a new named wordlist definition, when name is executed +; H: put the WID of the wordlist at the top of the search order +; H: the address of the body of the definition is the wid of the wordlist +dword VOCABULARY,"VOCABULARY" + ENTER + .dword CREATE + .dword _COMP_LIT + .dword H_FORTH ; root of all dictionaries + .dword LAST + .dword drXT ; XT of the just-created word + .dword COMMA + CODE + jsl f:_does + ENTER ; action of the vocabulary definition + .dword RPLUCKADDR + .dword INCR + .dword TOP_OF_ORDER + EXIT +eword + +.endif + +.if 0 ; half-baked +; ( -- ) +; "Restore all dictionary allocation and search order pointers to the state they had just +; prior to the definition of name. Remove the definition of name and all subsequent +; definitions. Restoration of any structures still existing that could refer to deleted +; definitions or deallocated data space is not necessarily provided. No other contextual +; information such as numeric base is affected." +; May need to change the wordlist structures to be a linked list so that we are aware of +; all of them, because at least one of them will have their head change and may not be +; in the search order. +; So in total when the marker is created we need to: +; * save HERE in order to deallocate the space later +; * save CURRENT to restore compiler word list +; * save the search order +; * save the heads of all wordlists +; * save the head of the wordlists list +; When the marker is executed, restore all of the above: +; * restoring head of the wordlists ensures removal of all wordlists +; that are removed by the marker +; * restoring the heads of the (remaining) wordlists removes all definitions created +; after the marker +; * restoring the search order and CURRENT ensures no removed wordlists are in use +; * Restoring HERE deallocates all dictionary space from the marker and beyond. +dword MARKER,"MARKER" + ENTER + + CODE + jsl f:_does + ENTER ; action of the marker + + EXIT +eword +.endif + +; H: ( "..." -- ) discard the rest of the input buffer (line during EVALUATE) +dword BACKSLASH,"\",F_IMMED + ENTER + .dword SOURCEID + .dword _IF + .dword term ; faster + ONLIT 0 ; something to drop... +lp: .dword DROP + .dword INQ + .dword _IF + .dword done + .dword GETCH + .dword DUP + ONLIT c_cr + .dword EQUAL + .dword _IFFALSE + .dword ddone ; if true (= CR) + .dword DUP + ONLIT c_lf + .dword EQUAL + .dword _IF + .dword lp ; if false (<> LF) +ddone: .dword DROP +done: EXIT +term: .dword NIN + .dword FETCH + .dword PIN + .dword STORE + EXIT +eword + +; H: ( char -- char' ) upper case convert char +dword UPC,"UPC" + jsr _1parm + lda STACKBASE+0,x + jsr _cupper + sta STACKBASE+0,x + NEXT +eword + +; H: ( char -- char' ) lower case convert char +dword LCC,"LCC" + jsr _1parm + lda STACKBASE+0,x + cmp #'A' + bcc done + cmp #'Z'+1 + bcs done + ora #$20 + sta STACKBASE+0,X +done: NEXT +eword + +; H: ( "name"<> ) parse name, place low 5 bits of first char on stack, if compiling stat +; H: compile it as a literal +dword CONTROL,"CONTROL",F_IMMED + ENTER + .dword CHAR + ONLIT $1F + .dword LAND + .dword _SMART + .dword interp + .dword LITERAL +interp: EXIT +eword + +; H: ( char base -- digit true | char false ) attempt to convert char to digit +dword DIGIT,"DIGIT" + jsr _2parm + lda STACKBASE+4,x + jsr _c_to_d + ldy #$0000 + bcc bad + cmp STACKBASE+0,x + bcs bad + sta STACKBASE+4,x + dey +bad: sty STACKBASE+0,x + sty STACKBASE+2,X + NEXT +eword + +; H: ( addr len -- true | n false ) attmept to convert string to number +dword dNUMBER,"$NUMBER" + ENTER + .dword OVER + .dword CFETCH + ONLIT '-' + .dword EQUAL + .dword PtoR + .dword RCOPY + .dword _IF + .dword :+ + .dword DECR + .dword SWAP + .dword INCR + .dword SWAP +: .dword TWOPtoR ; ( c-addr u -- ) + .dword ZERO ; ( -- 0 ) + .dword StoD ; ( 0 -- ud ) + .dword TWORtoP ; ( ud -- ud c-addr u ) + .dword GNUMBER ; ( ud c-addr u -- ud' c-addr' u' ) u' = 0 if no unconverted + .dword _IF ; ( ud' c-addr' u' -- ud' c-addr' ) + .dword okay + .dword THREEDROP ; ( ud' c-addr' -- ) + .dword RDROP ; lose negative + .dword TRUE ; ( -- tf ) + EXIT +okay: .dword DROP ; ( ud' c-addr' -- ud' ) + .dword DtoS ; ( ud' -- n ) + .dword RtoP + .dword QNEGATE + .dword FALSE ; ( n -- n ff ) + EXIT +eword + +; ( xx...xx1 -- yx...yx1 ) +; Interpret text from current input source +hword INTERPRET,"INTERPRET" + ENTER +loop: .dword INQ ; ( -- f ) + .dword _IF ; ( f -- ) + .dword done + .dword PARSE_WORD ; ( -- c-addr u ) + .dword QDUP ; ( c-addr u -- c-addr u | c-addr u u ) + .dword _IF ; ( c-addr u | c-addr u u | c-addr | c-addr u ) + .dword null + .dword TWODUP ; ( c-addr u -- c-addr u c-addr u ) + .dword SEARCH_ALL ; ( c-addr u c-addr u - c-addr u xt|0 ) + .dword QDUP ; ( c-addr u xt|0 -- c-addr u 0 | c-addr u xt xt ) + .dword _IF ; ( c-addr u 0 | c-addr u xt xt -- c-addr u | c-addr u xt ) + .dword trynum ; if xt = 0 + .dword DROP ; drop flag + .dword TWONIP ; ( c-addr u xt -- xt ) + .dword CONLYQ ; compile-only? (leaves xt on stack + .dword _IFFALSE + .dword conly + .dword _SMART ; no, see if we should compile or execute + .dword exec ; if interpreting +chkimm: .dword IMMEDQ ; compiling, immediate? (leaves xt on stack) + .dword _IFFALSE + .dword exec ; yes, go do it + NLIT COMPILECOMMA +exec: .dword EXECUTE + JUMP loop +trynum: .dword TWODUP ; ( c-addr u -- c-addr u c-addr u ) + .dword dNUMBER ; ( c-addr u c-addr u -- c-addr u num false | c-addr u true ) + .dword _IF + .dword goodnum ; false = good number + .dword SPACE + .dword TYPE + ONLIT '?' + .dword EMIT + NLIT -13 + .dword THROW +goodnum: .dword TWONIP + .dword _SMART + .dword loop ; if interpreting + .dword LITERAL + JUMP loop +conly: .dword _SMART + .dword trytemp ; if interpreting, try temporary def + JUMP chkimm ; otherwise check immediacy +trytemp: .dword TEMPDQ ; has flag for starting temp def + .dword _IFFALSE + .dword dotemp ; true, so start temporary def + .dword DROP ; otherwise bad state, drop XT + NLIT -14 ; and throw exception + .dword THROW +null: .dword DROP +done: EXIT + ; now we gotta do some juggling stack is ( xt ) +dotemp: .dword PtoR ; ( xt -- ) ( R: -- xt ) + .dword dTEMPCOLON ; start temporary colon definition + .dword RtoP ; ( -- xt ) ( R: xt -- ) + JUMP chkimm ; most or all of these should also be immediate... +eword + +; ( -- xn...x1 n ) save current source input state +dword SAVEINPUT,"SAVE-INPUT" + ENTER + .dword SOURCE ; address and length of current input + .dword PIN + .dword FETCH ; position in buffer + .dword SOURCEID + ONLIT 4 ; that was 4 things + EXIT +eword + +; ( xn...x1 n f1 -- f2 ) restore current source input state, including source ID if f1 is true +dword dRESTOREINPUT,"$RESTORE-INPUT" + ENTER + .dword SWAP ; ( ... addr len ptr srcid f 4 ) + ONLIT 4 ; ( ... addr len ptr srcid f 4 4 ) sanity check + .dword EQUAL ; ( ... addr len ptr srcid f1 f2 ) + .dword _IF ; ( ... addr len ptr srcid f ) + .dword bad + .dword _IF ; ( ... addr len ptr srcid ) + .dword nosrcid + .dword dSOURCEID ; ( ... addr len ptr srcid var ) + .dword STORE ; ( ... addr len ptr ) + JUMP :+ +nosrcid: .dword SOURCEID ; ( ... addr len ptr srcid srcid' ) + .dword EQUAL ; ( ... addr len ptr f ) + .dword _IF ; ( ... addr len ptr ) + .dword bad ; can't change sources +: .dword PIN ; otherwise restore all the things + .dword STORE + .dword NIN + .dword STORE + .dword dCIB + .dword STORE + .dword TRUE + EXIT +bad: ONLIT -12 + .dword THROW + EXIT +eword + +; ( xn...x1 n -- f ) restore current source input state, source ID must match current +dword RESTOREINPUT,"RESTORE-INPUT" + ENTER + .dword FALSE + .dword dRESTOREINPUT + EXIT +eword + +; H: ( xxn...xx1 c-addr u -- yxn...yx1 ) interpret text in c-addr u +dword EVALUATE,"EVALUATE" + ENTER + .dword SAVEINPUT + .dword NPtoR ; throw it all on the return stack + .dword PtoR ; along with the count + ONLIT -1 + .dword dSOURCEID ; standard requires source-id to be -1 during EVALUATE + .dword STORE + ONLIT 0 ; input to first character + .dword PIN + .dword STORE + .dword NIN ; string length to #IN + .dword STORE + .dword dCIB ; current input buffer to string address + .dword STORE + ONLIT INTERPRET + .dword CATCH ; we do this so that we can restore input if exception + .dword RtoP ; now put the input back to where we were + .dword NRtoP + .dword TRUE + .dword dRESTOREINPUT ; restore the input spec, including source ID + .dword DROP + .dword THROW ; finally, re-throw any exception + EXIT +eword + +; H: synonym for EVALUATE +dword EVAL,"EVAL" + bra EVALUATE::code +eword + +; ( "n"<> n ) parse number n, compile as literal if compiling +hword nNUM,"#NUM" + ENTER + .dword PARSE_WORD + .dword DUP + .dword _IF + .dword empty + .dword dNUMBER + .dword _IFFALSE + .dword bad + .dword _SMART + .dword interp + .dword LITERAL +interp: EXIT +empty: .dword TWODROP +bad: ONLIT -24 + .dword THROW +eword + + +; H: ( "#"<> -- n | -- ) parse following number as decimal, compile as literal if compiling +dword DNUM,"D#",F_IMMED + ENTER + ONLIT 10 +tmpbase: ONLIT nNUM + .dword SWAP + .dword TMPBASE + EXIT +eword + +; H: ( "#"<> -- n | -- ) parse following number as hex, compile as literal if compiling +dword HNUM,"H#",F_IMMED + ENTER + ONLIT 16 + JUMP DNUM::tmpbase +eword + +; H: ( "#"<> -- n | --) parse following number as octal, compile as literal if compiling +dword ONUM,"O#",F_IMMED + ENTER + ONLIT 8 + JUMP DNUM::tmpbase +eword + +; Forget is a stupidly dangerous word when you have multiple wordlists, noname words, +; and such. Not recommended to use except for the most recently-defined few words in +; the current wordlist. +; first we will scan the dictionary to see if the word to be forgotten is below +; the protection bit, and if it is found before we match the XT, we don't allow the +; forget +; ( xt -- ) +dword dFORGET,"$FORGET" + ENTER + .dword DUP ; ( xt -- xt xt' ) + .dword QDUP + .dword _IF + .dword cant + .dword rLINK ; ( xt xt' -- xt link ) + .dword _IF ; ( xt link -- xt ) + .dword cant + .dword LAST ; ( xt -- xt a-addr ) +lp: .dword DUP ; ( xt a-addr -- xt a-addr a-addr' ) + .dword drXT ; ( xt a-addr a-addr' -- xt a-addr xt2 ) + .dword DUP ; ( xt a-addr xt2 -- xt a-addr xt2 xt2' ) + .dword FETCH ; ( xt a-addr xt2 xt2' -- xt a-addr xt2 flags ) + ONLIT F_PROT ; ( xt a-addr xt2 flags -- xt a-addr xt2 flags F_PROT ) + .dword LAND ; ( xt a-addr xt2 flags F_PROT -- xt a-addr xt2 f ) + .dword _IFFALSE ; ( xt a-addr xt2 f -- xt a-addr xt2 ) + .dword prot + .dword SWAP ; ( ... xt xt2 a-addr ) + .dword PtoR ; ( ... xt xt2 ) ( R: -- a-addr ) + .dword OVER ; ( ... xt xt2 xt' ) + .dword EQUAL ; ( ... xt f ) + .dword _IFFALSE ; ( ... xt ) + .dword amnesia + .dword RtoP ; ( xt -- xt a-addr ) ( R: a-addr -- ) + .dword FETCH ; ( xt a-addr -- xt a-addr2 ) + .dword QDUP + .dword _IF + .dword cant + JUMP lp +amnesia: .dword RDROP ; ( R: a-addr -- ) + .dword rLINK + .dword DUP + .dword toHERE + .dword FETCH + .dword GET_CURRENT + .dword STORE + EXIT +prot: .dword TWODROP ; ( xt a-addr xt2 -- xt ) +cant: SLIT "Can't forget " ; ( xt -- xt str len ) + .dword TYPE ; ( xt str len -- xt ) + .dword rNAME ; ( xt -- str len ) + .dword TYPE ; ( str len -- ) + EXIT +eword + +; H: ( "name"<> -- ) attempt to forget name and subsequent definitions in compiler +; H: word list. This may have unintended consequences if things like wordlists and such +; H: were defined after name. +dword FORGET,"FORGET" + ENTER + .dword PARSEFIND + .dword dFORGET + EXIT +eword + +; remove any incomplete or temporary definitions +; executed by QUIT to clean up after an exception results in a return to the outer +; interpreter. +hword dPATCH,"$PATCH" + ENTER + .dword STATEI ; ensure interpretation state + .dword dTMPDEF + .dword FETCH + .dword _IF ; in the middle of a temporary definition? + .dword :+ ; no, see if we were doing a normal def + .dword dSAVEHERE ; ( -- a-addr ) restore HERE + .dword FETCH ; ( a-addr -- c-addr ) + .dword toHERE ; ( c-addr -- ) + ONLIT 0 ; ( -- 0 ) + .dword dTMPDEF ; ( 0 -- 0 a-addr ) + .dword DUP ; ( 0 a-addr -- 0 a-addr a-addr' ) + .dword FETCH ; ( 0 a-addr a-addr' -- 0 a-addr c-addr ) + ONLIT max_tempdef ; ( ... 0 a-addr c-addr u ) + .dword FREE ; ( ... 0 a-addr ) + .dword STORE ; ( 0 a-addr -- ) +: .dword OLDHERE ; is OLDHERE not 0? + .dword _IF + .dword nopatch ; is zero, no need to patch + .dword LAST ; it is! check smudge bit of last definition + .dword drXT + .dword CFETCH + ONLIT F_SMUDG + .dword LAND + .dword _IF ; is smudge bit set? + .dword nopatch ; nope, no need to patch + .dword LAST ; yes, start fixup by setting LAST to the value at [LAST] + .dword FETCH ; LAST @ + .dword GET_CURRENT ; CURRENT + .dword STORE ; ! + .dword OLDHERE ; fix HERE + .dword toHERE ; ->HERE + ONLIT 0 ; clear OLDHERE + .dword dOLDHERE ; $OLDHERE + .dword STORE ; ! +nopatch: EXIT +eword + +; H: ( -- ) ( R: ... -- ) enter outer interpreter loop, aborting any execution +dword QUIT,"QUIT" + lda RSTK_TOP ; reset return stack pointer + tcs + ENTER + .dword dPATCH ; fix top of dictionary/remove temp defs + .dword CR +source0: .dword SETKBD ; set keyboard as input source +lp: ONLIT 0 ; clear #LINE since we are at input prompt + .dword NLINE + .dword STORE + .dword REFILL ; fill input buffer + .dword _IF ; get anything? + .dword source0 ; no, reset to keyboard and get more + .dword INTERPRET ; otherwise, interpret + .dword dSTATUS ; display status + JUMP lp +eword +__doquit = QUIT::code + +PLATFORM_INCLUDE "platform-words.s" ; Platform additional dictionary words + +; Leave these toward the top + +; H: ( -- -1 ) +dword MINUSONE,"-1" + lda #$FFFF + tay + PUSHNEXT +eword + +; H: ( -- 3 ) +dword THREE,"3" + FCONSTANT 3 +eword + +; H: ( -- 2 ) +dword TWO,"2" + FCONSTANT 2 +eword + +; H: ( -- 1 ) +dword ONE,"1" + lda #$0000 + tay + iny + PUSHNEXT +eword + +; H: ( -- 0 ) +dword ZERO,"0" + lda #$0000 + tay + PUSHNEXT +eword + + +dend + + diff --git a/asm/interpreter.s b/asm/interpreter.s new file mode 100644 index 0000000..8b64372 --- /dev/null +++ b/asm/interpreter.s @@ -0,0 +1,1078 @@ +; Inner interpreter and support routines, and basic stack manipulation routines. + + +; Inner interpreter entry and Forth call nesting +; this inner interpreter expects cell-sized absolute references to other definitions +; Expectations: +; call with JSL in native mode with long registers +; D register: address of direct page to be used for low-level system functions and +; working registers. +; S register: return stack +; X register: data stack pointer in bank 0, relative to D register. +; See equates.inc. SP_MIN and SP_MAX reflect minimum and maximum allowed stack pointer +; Pops caller from return stack and initializes IP with it +; saving previous IP on return stack. +.if 1 ; faster +.proc _enter + .if trace + lda IP + ldy IP+2 + wdm $81 + .endif + phb ; (3) dummy value + lda 2,s ; (5) + ldy IP ; (4) + sta IP ; (4) + tya ; (2) + sta 1,s ; (5) + lda 4,s ; (5) + ldy IP+2 ; (4) + and #$FF ; (3) + sta IP+2 ; (4) + tya ; (2) + sta 3,s ; (5) + ; fall-through ; (46 cycles) +.endproc +.else ; original implementation +.proc _enter + ldy IP ; (4) + lda IP+2 ; (4) + .if trace + wdm $81 + .endif + sta TMP1 ; (4) + pla ; (5) + sta IP ; (4) + sep #SHORT_A ; (3) + pla ; (4) + rep #SHORT_A ; (3) + and #$FF ; (3) + sta IP+2 ; (4) + lda TMP1 ; (4) + pha ; (4) + phy ; (4) + ; fall-through ; (50 cycles) +.endproc +.endif + +.proc _next + inc IP ; inline fetch + bne :+ + inc IP+2 +: lda [IP] ; low word + tay + inc IP + bne :+ + inc IP+2 +: inc IP + bne :+ + inc IP+2 +: lda [IP] ; high word + inc IP + bne :+ + inc IP+2 +: +.if !no_fast_lits + ora #$0000 ; faster than php+plp + beq fast_num +.endif +run: sep #SHORT_A + pha + rep #SHORT_A + phy + rtl +fast_num: jsr _pushay + bra _next +.endproc + + +; Exit Forth thread: restore previous IP from return stack +; and resume execution +.proc _exit_next + ply + pla + .if trace + wdm $83 + .endif + sty IP + sta IP+2 + NEXT +.endproc + +; Exit Forth thread, resume native code execution at IP+1 by swapping the 32-bit IP on the +; stack for the low 24 bits of the Forth IP +.proc _exit_code +.if 1 ; ever so slightly faster, eliminate TMP1 use + .if trace + lda IP+2 + ldy IP + wdm $82 + .endif + lda 3,s ; (5) + tay ; (2) + lda IP+1 ; (4) note offset is 1 to get high & middle bytes + sta 3,s ; (5) + sty IP+2 ; (4) + lda 1,s ; (5) + tay ; (2) + lda IP ; (4) + sta 2,s ; (5) note offset is 2 to place low (& middle again) bytes + sty IP ; (4) + tsc ; (2) + inc a ; (2) drop the extra byte + tcs ; (2) + rtl ; (47 cycles) +.else ; original + ldy IP ; (4) + lda IP+2 ; (4) + sta TMP1 ; (4) + pla ; (5) + sta IP ; (4) + pla ; (5) + sta IP+2 ; (4) + lda TMP1 ; (4) + .if trace + wdm $82 + .endif + sep #SHORT_A ; (3) + pha ; (4) + rep #SHORT_A ; (3) + phy ; (4) + rtl ; (48 cycles) +.endif +.endproc + +.proc _fetch_ip_word + inc IP + bne :+ + inc IP+2 +: lda [IP] + ; fall-through +.endproc + +.proc _inc_ip ; note fall-through from above! + inc IP + bne :+ + inc IP+2 +: rts +.endproc + +.proc _fetch_ip_byte + inc IP + bne :+ + inc IP+2 +: lda [IP] + and #$00FF + rts +.endproc + +.proc _fetch_ip_cell + inc IP + bne :+ + inc IP+2 +: lda [IP] + tay + inc IP + bne :+ + inc IP+2 +: inc IP + bne :+ + inc IP+2 +: lda [IP] + inc IP + bne :+ + inc IP+2 +: rts +.endproc + +; convert XT address in YR to header address in YR +; return carry set if word has header +; return carry clear if word does not have header (is noname) +; Y = name length +.proc _xttohead +lp: jsr _decyr ; first one decrements before flags + lda [YR] + and #$80 ; see if it's the name length field + beq lp ; nope, go back again + lda [YR] ; get it back + and #$7F ; mask in length + tay ; and save it + beq nohead +yrminus4: lda YR + sec ; move to link field + sbc #$04 + sta YR + lda YR+2 + sbc #$00 + sta YR+2 + sec ; flag OK + rts +nohead: clc + rts +.endproc +_yrminus4 = _xttohead::yrminus4 + +.if 0 +; Get caller address (must call with JSL) +.proc _trace_word + ldy #'>' + jsr _emit + lda 1,S ; get caller address + sta WR + lda 3,S + sta WR+2 + jsr _wrminus4 ; get xt + lda WR ; copy xt to YR + sta YR + lda WR+2 + sta YR+2 + jsr _xttohead ; go to header + bcc do_hex ; No name + sty XR ; save length + stz XR+2 + lda YR ; put address of name back into WR + clc + adc #$04 + sta WR + lda YR+2 + adc #$00 + sta WR+2 + ldy #.loword(do_emit-1) + lda #.hiword(do_emit-1) + jsr _str_op_ay ; now print word (destroys YR) +spacer: lda #' ' ; print a space and cleverly fall through +do_emit: tay + jsr _emit + clc + rtl +do_hex: jsr _incwr ; Move to word XT address + ldy #'$' ; because that's what we want to print + jsr _emit + lda WR+2 ; high word + jsr prhex ; print + lda WR ; low word + jsr prhex ; print + bra spacer ; and done +prhex: sta XR ; save it + lda #$04 ; 4 digits to do + sta XR+2 ; counter loc +digit: lda #$0000 ; start with nothing + clc ; rotate 4 bits from XR to A + rol XR + rol a + rol XR + rol a + rol XR + rol a + jsr _dtoc ; convert to ASCII + tay + jsr _emit ; and print + dec XR+2 + bne digit ; do the rest if there are some left + rts +.endproc +.endif + +; Stack primitives +; stack starts at STK_TOP and grows down toward STK_BTM +; STK_BTM points at the last usable cell +; STK_TOP points at the location above the first usable cell +.proc _stackdecr + cpx STK_BTM ; past the bottom already? + bcc _stko_err + dex + dex + dex + dex + rts +.endproc + +.proc _stackincr + cpx STK_TOP ; already past where we can be? + bcs _stku_err ; yep, underflowed stack + inx + inx + inx + inx + rts +.endproc + +.proc _popay + lda STACKBASE+2,x + ldy STACKBASE+0,x + .if trace + wdm $85 + .endif + bra _stackincr +.endproc + +.proc _peekay + cpx STK_TOP + bcs _stku_err + lda STACKBASE+2,x + ldy STACKBASE+0,x + rts +.endproc + +.proc _popwr + jsr _popay + sty WR + sta WR+2 + rts +.endproc + +; no stack depth check +.proc _peekwr + lda STACKBASE+0,x + sta WR + lda STACKBASE+2,x + sta WR+2 + rts +.endproc + +.proc _popxr + jsr _popay + sty XR + sta XR+2 + rts +.endproc + +.proc _popyr + jsr _popay + sty YR + sta YR+2 + rts +.endproc + +.proc _stku_err + ldx STK_TOP + ldy #.loword(-4) + lda #.hiword(-4) + jmp _throway +.endproc + +.proc _1parm + cpx STK_TOP + bcs _stku_err + rts +.endproc + +.proc _l1parm + jsr _1parm + rtl +.endproc + +.proc _2parm + txa + clc + adc #$04 +docmp: cmp STK_TOP + bcs _stku_err + rts +.endproc + +.proc _l2parm + jsr _2parm + rtl +.endproc + +.proc _3parm + txa + clc + adc #$08 + bra _2parm::docmp +.endproc + +.proc _l3parm + jsr _3parm + rtl +.endproc + +.proc _4parm + txa + clc + adc #$0C + bra _2parm::docmp +.endproc + +.proc _l4parm + jsr _4parm + rtl +.endproc + + +.proc _stko_err + lda STK_BTM + clc + adc #32 ; 8 cells + tax + ldy #.loword(-3) + lda #.hiword(-3) + jmp _throway +.endproc + +.proc _pushay + .if trace + wdm $86 + .endif + jsr _stackdecr + sta STACKBASE+2,x + sty STACKBASE,x + rts +.endproc + +.proc _pusha + .if trace + phy + tay + lda #$00 + jsr _pushay + ply + .else + jsr _stackdecr + stz STACKBASE+2,x + sta STACKBASE,x + .endif + rts +.endproc + +.proc _swap + jsr _2parm + ; fall-through +.endproc + +; when we know there are 2 parms on stack... +.proc _swap1 + lda STACKBASE+6,x + ldy STACKBASE+2,x + sty STACKBASE+6,x + sta STACKBASE+2,x + lda STACKBASE+4,x + ldy STACKBASE+0,x + sty STACKBASE+4,x + sta STACKBASE+0,x + rts +.endproc + +.proc _over + jsr _2parm + ldy STACKBASE+4,x + lda STACKBASE+6,x + jmp _pushay +.endproc + + +; Interpretation routines + +; Push word data address, default routine used by CREATE +; call via JSL, pops return stack entry, pushes data address +; onto data stack +.proc _pushda + pla + clc + adc #$01 + tay + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + PUSHNEXT +.endproc + +; Pushes cell following JSL onto the stack +.proc _pushvalue + pla + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+2 +pushv2: ldy #$02 + lda [WR],y ; high word + pha ; save for now + dey + dey + lda [WR],y ; low word + tay + pla + PUSHNEXT +.endproc + +; Pushes stack top + cell following JSL onto the stack +.proc _field + jsr _1parm + pla + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+2 + ldy #$00 + lda [WR],y ; low word + clc + adc STACKBASE+0,x + sta STACKBASE+0,x + iny + iny + lda [WR],y ; low word + adc STACKBASE+0,x + sta STACKBASE+0,x + NEXT +.endproc + +.proc _push2value + pla + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+2 + ldy #$06 + lda [WR],y ; high word + pha ; save for now + dey + dey + lda [WR],y ; low word + tay + pla + jsr _pushay + bra _pushvalue::pushv2 +.endproc + +; Return address of system variable # following the JSL +.proc _sysvar + pla ; return address + 1 -> WR + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+2 + lda [WR] ; get sysvar number (max of 16384*4) + clc + adc SYSVARS ; add to address of SYSVARS + tay + lda SYSVARS+2 + adc #$00 + PUSHNEXT +.endproc + +; Jumps to the XT following JSL +.proc _deferred + pla + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+2 + ldy #$02 + lda [WR],y ; high word + sep #SHORT_A + pha ; bank byte on stack + rep #SHORT_A + dey + dey + lda [WR],y ; low word + pha ; address on stack + rtl ; really a jump +.endproc + +; After pop from data stack into AY, jumps to the XT following JSL +.proc _pop_deferred + pla + clc + adc #$01 + sta WR + sep #SHORT_A + pla + rep #SHORT_A + and #$FF + adc #$00 + sta WR+1 + ldy #$02 + lda [WR],y ; high word + sep #SHORT_A + pha ; bank byte on stack + rep #SHORT_A + dey + dey + lda [WR],y ; low word + pha ; RTS address on stack + jsr _popay + rts ; really a jump +.endproc + +; ensure at least room for 8 items on stack +.proc _stackroom + txa + sec + sbc #$20 ; see if there is room for 8 items on stack + cmp STK_BTM + bcc makeroom +chktop: cpx STK_TOP ; new see if we are above the top + bcc :+ + ldx STK_TOP +: rts +makeroom: txa + adc #$20 + tax + bra chktop +.endproc + +.proc _unimpl + ldy #.loword(-21) + lda #.hiword(-21) + jmp _throway +.endproc + +.proc _callyr + tay + lda YR+2 + sep #SHORT_A + pha + rep #SHORT_A + lda YR + pha + tya + rtl +.endproc + +.proc _str_op_ay + sta YR+2 + sty YR + ; fall-through +.endproc + +; Perform a "string" operation on the string pointed at in WR +; with length in XR and function in YR (address less 1) +; YR is called with A containing the byte from the string +; XR is converted to last address plus one of the string +; [YR] should return with carry clear if processing is to continue +; and carry set if it not. +; note YR is called with long registers +.proc _str_op + lda WR + clc + adc XR + sta XR + lda WR+2 + adc XR+2 + sta XR+2 +loop: lda WR+2 + cmp XR+2 + bne :+ + lda WR + cmp XR +: bcc :+ +done: rts +: lda [WR] + and #$00FF ; compensate for long register + jsl f:_callyr + bcs done + jsr _incwr + bra loop +.endproc + +; do string op with function in AY and string described by (c-addr u) on +; top of data stack +.proc _str_op_ays + sta YR+2 + sty YR + jsr _popxr ; u -> XR + jsr _popwr ; c-addr -> YR + bra _str_op +.endproc + +.proc _iter_ay + sta YR+2 + sty YR + ; fall-through +.endproc + +; Perform a function pointed at in YR with count in XR times +; iteration # (from 0) will be in WR +; [YR] should return with carry clear if processing is to continue +; and carry set if it not. +.proc _iter + stz WR + stz WR+2 + lda XR + ora XR+2 + beq done ; in case no loops requested +loop: jsl f:_callyr + bcs done + jsr _incwr + lda WR+2 + cmp XR+2 + bne :+ + lda WR + cmp XR +: bcc loop +done: rts +.endproc + +.proc _decay + cpy #$0000 + bne :+ + dec a +: dey + rts +.endproc + +; get AY from [WR] +.proc _wrfetchind + ldy #$02 + lda [WR],y + pha + dey + dey + lda [WR],y + tay + pla + rts +.endproc + +; store AY into [WR] +.proc _wrstoreind + phy + ldy #$02 + sta [WR],y + dey + dey + pla + sta [WR],y + rts +.endproc + +.proc _incwr + inc WR + bne :+ + inc WR+2 +: rts +.endproc + +.proc _decwr + lda WR + bne :+ + dec WR+2 +: dec WR + rts +.endproc + +.proc _decxr + lda XR + bne :+ + dec XR+2 +: dec XR + rts +.endproc + +.proc _decyr + lda YR + bne :+ + dec YR+2 +: dec YR + rts +.endproc + +.proc _wrplus4 + lda WR + clc + adc #$04 + sta WR + lda WR+2 + adc #$00 + sta WR+2 + rts +.endproc + +.proc _wrminus4 + lda WR + sec + sbc #$04 + sta WR + lda WR+2 + sbc #$00 + sta WR+2 + rts +.endproc + +.if 0 +.proc _wrplusxr + lda WR + clc + adc XR + sta WR + lda WR+2 + adc XR+2 + sta WR+2 + rts +.endproc + +.proc _wrminusxr + lda WR + sec + sbc XR + sta WR + lda WR+2 + sbc XR+2 + sta WR+2 + rts +.endproc +.endif + +; conversion helpers + +; Digit to ASCII character +.proc _d_to_c + clc + adc #'0' + cmp #'9'+1 + bcc :+ + adc #6 +: rts +.endproc + +; ASCII character to digit +; return carry clear if bad +; carry set if good +.proc _c_to_d + and #$ff + jsr _cupper + sec + sbc #'0' + bmi bad + cmp #10 + bcc good + sbc #7 + bmi bad + cmp #10 + bcc bad ; so things like < don't convert + cmp #37 + bcc good +bad: clc + rts +good: sec + rts +.endproc + +; Upper case a character in accumulator +.proc _cupper + cmp #'z'+1 + bcs :+ + cmp #'a' + bcc :+ + and #$DF +: rts +.endproc + +; Upper case a character, 8 bit accumulator +.a8 +.proc _cupper8 + and #$7F + cmp #'z'+1 + bcs :+ + cmp #'a' + bcc :+ + and #$DF +: rts +.endproc +.a16 + +; Move XR bytes from [WR] to [YR], starting at the bottom +; trashes WR, YR, and XR +; could be optimized to move words, excepting the last one if odd number of bytes +; use for moving data downward, but that adds two comparison instructions which +; are slower than the SEP/REP, maybe +.proc _move +.if 1 ; fast move in memmgr.s + sec + jmp _memmove_c +.else ; slower but smaller move +lp: lda XR+2 ; see if zero bytes + ora XR + bne :+ + rts +: jsr _decxr ; pre-decrement XR + sep #SHORT_A + lda [WR] + sta [YR] + rep #SHORT_A + jsr _incwr ; post increment WR + inc YR ; and YR + bne lp + inc YR+2 + bra lp +.endif +.endproc + +; Move XR bytes from [WR] to [YR], starting at the top +; trashes YR and XR +; could be optimized to move words, excepting the last one if odd number of bytes +; use for moving data upward +.proc _moveup +.if 1 ; fast move in memmgr.s + clc + jmp _memmove_c +.else ; slower but smaller move +lp: jsr _wrplusxr + lda WR ; move WR to 1 past the end of the block + clc + adc XR + sta WR + lda WR+2 + adc XR+2 + sta WR+2 + lda YR ; move YR to 1 past the end of the block + clc + adc XR + sta YR + lda YR+2 + adc XR+2 + sta YR+2 + lda XR+2 + ora XR + bne :+ + rts +: jsr _decxr ; decrement XR + jsr _decwr ; and WR + jsr _decyr ; and YR + sep #SHORT_A + lda [WR] + sta [YR] + rep #SHORT_A + bra lp +.endif +.endproc + +; With word header address in YR, set YR to previous dictionary entry header +; return with Z flag set if the new address is zero +.proc _prevword + ldy #$00 + lda [YR],y ; low word + pha + iny + iny + lda [YR],y ; high word + sta YR+2 + pla + sta YR + ora YR+2 ; set Z flag + rts +.endproc + + +; search dictionary for word at WR, length in XR, start of search (header) at YR +; if found, AY=XT and carry set, otherwise +; AY=0 and carry clear +; preserves WR, XR, and YR +.proc _search +olp: lda YR + ora YR+2 + beq notfnd + ldy #$04 ; offset of length + lda [YR],y ; get name length + and #$7F ; mask in significant bits + cmp XR ; compare to supplied + bne snext ; not the right word + ; its the right length, compare name + lda WR+2 ; save WR + pha + lda WR + pha + phx ; save SP + sep #SHORT_A ; need to compare bytes + .a8 + ldx XR ; get length to match + ldy #$05 ; offset of name +clp: lda [WR] + jsr _cupper8 ; upper case + cmp [YR],y ; compare char + bne xsnext ; no match + iny ; move to next char + jsr _incwr + dex ; if X hit zero, matched it all + bne clp ; if it didn't, keep going + rep #SHORT_A ; match! + .a16 + plx ; restore SP + pla + sta WR ; restore WR, in case caller needs it + pla + sta WR+2 + tya ; y = 5+namelen=offset of flags=XT + clc + adc YR + tay + lda YR+2 + adc #$00 ; AY=XT + sec + rts +xsnext: rep #SHORT_A + plx + pla + sta WR + pla + sta WR+2 +snext: jsr _prevword + bne olp +notfnd: lda #$00 + tay + clc + rts +.endproc + +; find word, skipping any smudged word +.proc _search_unsmudged +lp: jsr _search + bcs :+ ; if carry clear + rts ; it wasn't found anyway +: pha ; save xt + phy + lda WR+2 ; save WR + pha + lda WR + pha + lda 5,s ; put xt in WR + sta WR + lda 7,s + sta WR+2 + lda [WR] ; get flags at xt address + ply ; restore WR + sty WR + ply + sty WR+2 + and #F_SMUDG + beq f_ok ; not set, word is OK + pla ; otherwise drop xt from return stack + pla + jsr _prevword ; go to previous word + bne lp ; and search if more + clc ; otherwise flag not found + rts +f_ok: ply ; get XT back + pla + sec + rts +.endproc + diff --git a/asm/mathlib.s b/asm/mathlib.s new file mode 100644 index 0000000..83c64fe --- /dev/null +++ b/asm/mathlib.s @@ -0,0 +1,384 @@ + +; Math Library - I don't reinvent the wheel here for multiplication, division, etc. +; others have done great work before me and I credit them when I know who did it. + +; 32-bit signed comparison +; C and Z reflect same comparision results as CMP instruction +.proc _stest32 + lda STACKBASE+6,x + eor STACKBASE+2,x + bpl samesign + lda STACKBASE+4,x + cmp STACKBASE+0,x + lda STACKBASE+6,x + sbc STACKBASE+2,x + bvs :+ + eor #$8000 +: sec + rol + rts +samesign: lda STACKBASE+6,x + cmp STACKBASE+2,x + bcc :+ ; less than or not equal, done + bne :+ + lda STACKBASE+4,x + cmp STACKBASE+0,x +: rts +.endproc + +.proc _invertay + pha + tya + eor #$FFFF + tay + pla + eor #$FFFF + rts +.endproc + +.proc _negateay + pha + tya + eor #$FFFF + clc + adc #$0001 + tay + pla + eor #$FFFF + adc #$0000 + rts +.endproc + +.proc _invert + lda STACKBASE+0,x + eor #$FFFF + sta STACKBASE+0,x + lda STACKBASE+2,x + eor #$FFFF + sta STACKBASE+2,x + rts +.endproc + +.proc _negate + jsr _invert + inc STACKBASE+0,x + bne :+ + inc STACKBASE+2,x +: rts +.endproc + +.proc _dinvert + jsr _invert + lda STACKBASE+4,x + eor #$FFFF + sta STACKBASE+4,x + lda STACKBASE+6,x + eor #$FFFF + sta STACKBASE+6,x + rts +.endproc + +.proc _dnegate + jsr _dinvert + inc STACKBASE+4,x + bne :+ + inc STACKBASE+6,x + bne :+ + inc STACKBASE+0,x + bne :+ + inc STACKBASE+2,x +: rts +.endproc + +.proc _2abs + bit STACKBASE+2,x + bpl :+ + jsr _negate +: jsr _swap + ; fall-through +.endproc + +.proc _abs + bit STACKBASE+2,x + bpl :+ + jsr _negate +: rts +.endproc + +.proc _signum + ldy #$FFFF + lda STACKBASE+2,x + bpl :+ + sty STACKBASE+2,x + bra done +: iny + stz STACKBASE+2,x + ora STACKBASE+0,x + beq done + iny +done: sty STACKBASE+0,x + rts +.endproc + +; 32-bit unsigned multiplication with 64-bit result +; right-shifting version by dclxvi +; scratch in YR, YR+2 (preserved) +.proc _umult +N = YR + lda N+2 + pha + lda N + pha + lda #$00 + sta N + ldy #32 + lsr STACKBASE+6,x + ror STACKBASE+4,x +l1: bcc l2 + clc + sta N+2 + lda N + adc STACKBASE+0,x + sta N + lda N+2 + adc STACKBASE+2,x +l2: ror + ror N + ror STACKBASE+6,x + ror STACKBASE+4,x + dey + bne l1 + sta STACKBASE+2,x + lda N + sta STACKBASE+0,x + pla + sta N + pla + sta N+2 + rts +.endproc + +; 64-bit divided by 32-bit with 32-bit quotient and remainder +; Adapted from Garth's routine, just like everyone else :-) +; carry set if divison by zero or overflow +; ( d n -- r q ) +; d.hi = stack(4,6), d.low = stack(8,10), n=stack(0,2) +.proc _umdivmod +CARRY = YR +SCRATCH = YR+2 +.if 1 ; shortcut 32-bit by 32-bit division + lda STACKBASE+4,x + ora STACKBASE+6,x + beq _udivmod32 ; go do faster 32-bit divide +.endif + lda SCRATCH + pha + lda CARRY + pha + sec ; first, check for overflow and division by 0 + lda STACKBASE+4,x + sbc STACKBASE+0,x + lda STACKBASE+6,x + sbc STACKBASE+2,x + bcs overflow + lda #33 ; 32 bits + 1 + sta XR +loop: rol STACKBASE+8,x + rol STACKBASE+10,x + dec XR + beq done + rol STACKBASE+4,x + rol STACKBASE+6,x + stz CARRY + rol CARRY + sec + lda STACKBASE+4,x + sbc STACKBASE+0,x + sta SCRATCH + lda STACKBASE+6,x + sbc STACKBASE+2,x + tay + lda CARRY + sbc #0 + bcc loop + lda SCRATCH + sta STACKBASE+4,x + sty STACKBASE+6,x + bra loop +overflow: sec + bra done1 +done: clc + inx ; drop + inx + inx + inx +done1: pla + sta CARRY + pla + sta SCRATCH + bcs :+ ; leave stack intact if exception + jmp _swap1 +: rts +.endproc + +; 32-bit by 32-bit division +; assumes that the second stack entry is zero +; ( d n -- r q ) where d.hi is zero e.g. ( n1 0 n2 -- r q ) +; d.hi = stack(4,6) = 0, d.low = n1 = stack(8,10), n2 = stack(0,2) +.proc _udivmod32 + lda #32 + sta XR +l1: asl STACKBASE+8,x ; shift high bit of n1 into r + rol STACKBASE+10,x ; clearing the low bit for q + rol STACKBASE+4,x ; r.lo + rol STACKBASE+6,x ; r.hi + lda STACKBASE+4,x ; r.lo + sec ; trial subraction + sbc STACKBASE+0,x ; n2.lo + tay ; save low word + lda STACKBASE+6,x ; r.hi + sbc STACKBASE+2,x ; n2.hi + bcc l2 ; subtraction succeeded? + sta STACKBASE+6,x ; r.hi yes, save result + sty STACKBASE+4,x ; r.lo + inc STACKBASE+8,x ; n1.lo and record a 1 in the quotient +l2: dec XR ; next bit + bne l1 + inx ; kill of top stack item + inx + inx + inx + clc ; this *never* overflows + jmp _swap1 +.endproc + +; ( d n -- ud u ) +.proc _dnabs + lda STACKBASE+2,x ; take absolute value of n1 + bpl :+ + jsr _negate +: lda STACKBASE+6,x ; take absolute value of d + bpl :+ +dtneg: inx + inx + inx + inx + jsr _dnegate + dex + dex + dex + dex +: rts +.endproc +_dtucknegate = _dnabs::dtneg + +.proc _smdivrem + lda STACKBASE+6,x ; save dividend sign in MSW of high cell of d + pha + eor STACKBASE+2,x ; compute result sign and save + pha + jsr _dnabs ; take absolute value of arguments + jsr _umdivmod + bcs overflow ; overflow + pla ; see if we should negate quotient + bpl :+ + jsr _negate ; make it negative +: pla ; get dividend sign + bpl :+ +tneg: inx ; negate remainder if it should be negative + inx + inx + inx + jsr _negate + dex + dex + dex + dex +: clc + rts +overflow: pla ; carry is set, pla does not affect it + pla + rts +.endproc +_tucknegate = _smdivrem::tneg + +.proc _fmdivmod + stz WR + lda STACKBASE+2,x + bpl :+ + dec WR + jsr _dnabs +: lda STACKBASE+6,x + bpl :+ + lda STACKBASE+0,x + clc + adc STACKBASE+4,x + sta STACKBASE+4,x + lda STACKBASE+2,x + adc STACKBASE+6,x + sta STACKBASE+6,x +: jsr _umdivmod + bcs :+ + bit WR + bpl :+ + jsr _tucknegate ; clears carry +: rts +.endproc + +; adapted from Lee Davidson routine +; ( u1 -- u1 u2 ) u1 = closest integer <= square root, u2 = remainder +; number popped into WR,WR+2 +; remainder on stack, offsets 0,2 +; root on stack, offsets 4,6 +; temp in YR +; counter in XR +.proc _sqroot + jsr _peekwr ; get number into WR + jsr _stackdecr ; make room for remainder + lda #16 ; pairs of bits + sta XR ; counter + lda #$0000 + sta STACKBASE+0,x ; init remainder + sta STACKBASE+2,x + sta STACKBASE+4,x ; init root + sta STACKBASE+6,x + +lp: asl STACKBASE+4,x ; root = root * 2 + asl WR ; now shift 2 bits of number into remainder + rol WR+2 + rol STACKBASE+0,x + rol STACKBASE+2,x + asl WR + rol WR+2 + rol STACKBASE+0,x + rol STACKBASE+2,x + lda STACKBASE+4,x ; copy root into temp + sta YR + lda STACKBASE+6,x ; (a bit shorter than immediate load) + sta YR+2 + sec ; +1 + rol YR ; temp = temp * 2 + 1 + rol YR+2 + lda STACKBASE+2,x ; compare remainder with partial + cmp YR+2 + bcc next ; skip sub if remainder smaller + bne subtr ; but do it if equal + lda STACKBASE+0,x + cmp YR + bcc next ; same deal +subtr: lda STACKBASE+0,x ; subtract partial from remainder + sbc YR + sta STACKBASE+0,x + lda STACKBASE+2,X + sbc YR+2 + sta STACKBASE+2,x + inc STACKBASE+4,x ; no need to increment high word, always zero +next: dec XR + bne lp + rts +.endproc + + + + + diff --git a/asm/memmgr.s b/asm/memmgr.s new file mode 100644 index 0000000..c6bcbf0 --- /dev/null +++ b/asm/memmgr.s @@ -0,0 +1,626 @@ + +; Memory allocation library + +; Structure is a linked list beginning at HIMEM and ending at MEM_TOP +; when HIMEM=MEM_TOP, nothing is allocated +; where each entry in the list is +; flag+chk is a 16-bit item whose top bit is 1 for in-use, 0 if free +; at some point, the remainder of the word are the low bits of the address of this +; block header in order to serve as a check for heap corruption + +; Allocation is selectable from first-fit or best fit (see below) for extant free blocks +; Freeing the bottom block moves HIMEM up. Adjacent free blocks are combined. + + +; Tunables +SPLIT_THRESH = 8 ; if block can be split and remainder have this many + ; bytes + 6 bytes header, split it +MIN_BRK = $400 ; minimum break between DHERE and HIMEM in pages + +; Constants +HDR_SIZE = 6 + +; Allocate XR bytes, return carry set+pointer in AY if successful +; or carry clear+AY=0 if unsuccessful +; trashes WR (has copy of pointer to the block header) and YR +; This uses a first-fit algorithm. If the selected block has at bytes +; remaining after the allocation, the block will be split with the remaining +; space (less 4 bytes) put into the newly following block +.proc _alloc + jsr _chk_himem + bcs grow + jsr _find_free + bcs grow + ; reuse, y = 4, A = existing flag word + ora #$8000 + sta [WR],y + jsr _split ; split block if possible + bra _rtn_ptr +grow: jsr _grow_heap + bcs :+ + ldy #$0004 + lda #$8000 + sta [WR],y + bra _rtn_ptr +: lda #$00 + tay + clc + rts +.endproc + +.proc _rtn_ptr + lda WR + clc + adc #.loword(HDR_SIZE) + tay + lda WR+2 + clc + adc #.hiword(HDR_SIZE) + sec + rts +.endproc + +.proc _split + jsr _blksize + lda YR ; YR = YR(size)-XR(requested size) = remaining space + sec + sbc XR + sta YR + lda YR+2 + sbc XR+2 + sta YR+2 + lda YR ; now see if it's big enough to split + sec + sbc #.loword(SPLIT_THRESH+HDR_SIZE) + ldy YR+2 + sbc #.hiword(SPLIT_THRESH+HDR_SIZE) + bmi done ; do not split, it's too small + lda WR ; set YR to be a pointer to the child block + clc ; YR = WR+XR+6 + adc XR + sta YR + lda WR+2 + adc XR+2 + sta YR+2 + lda YR ; (now account for header of parent block) + clc + adc #.loword(HDR_SIZE) + sta YR + lda YR+2 + adc #.hiword(HDR_SIZE) + sta YR+2 ; ok now YR points to child block + ldy #$04 ; first mark child block free + lda #$0000 ; by zeroing its flags + sta [YR],y + dey + dey ; y = $02 + lda [WR],y ; then copy high word next block pointer of parent + sta [YR],y ; into high word next block pointer of child + dey + dey ; y = $00 + lda [WR],y ; and then do low word next block pointer + sta [YR],y ; copy to child + lda YR ; then set parent next block pointer to child + sta [WR],y ; low word + iny + iny ; y = $02 + lda YR+2 ; high word + sta [WR],y +done: rts +.endproc + +; Load SV_HIMEM into WR and compare to MEM_TOP +; return carry set if MEM_TOP >= SV_HIMEM +; carry clear, otherwise +.proc _chk_himem + ldy #SV_HIMEM + lda [SYSVARS],y + sta WR + iny + iny + lda [SYSVARS],y + sta WR+2 + ; fall-through +.endproc + +; See if WR is at (or above) MEM_TOP +; Z and C reflect usual meanings +.proc _chktop + lda WR+2 + cmp MEM_TOP+2 + bne :+ + lda WR + cmp MEM_TOP +: rts +.endproc + +; Move WR to the next block, assuming WR points to an existing block +; return via comparison with MEM_TOP +.proc _nextblk + ldy #$00 + lda [WR],y + pha + iny + iny + lda [WR],y + sta WR+2 + pla + sta WR + bra _chktop +.endproc + +; YR = [WR] - WR - 6 +.proc _blksize + ldy #$00 + lda [WR],y + sec + sbc WR + sta YR + iny + iny + lda [WR],y + sbc WR+2 + sta YR+2 + lda YR + sec + sbc #$0006 + sta YR + lda YR+2 + sbc #$0000 + sta YR+2 + rts +.endproc + +.if 0 ; use first-fit if nonzero, best-fit if zero +; Find a free block of at least size XR +; if found, return with its address in WR and carry clear, YR is the block size, A +; is the contents of the flags word, and Y is 4 +; otherwise carry set and WR should be equal to HIMEM +.proc _find_free + jsr _chk_himem + bcc lp + rts +next: jsr _nextblk + bcs done +lp: jsr _blksize + lda YR+2 + cmp XR+2 + bne :+ + lda YR + cmp XR +: bcc next ; too big + ldy #$04 ; got one, is it free? + lda [WR],y + bmi next ; nope + clc +done: rts +.endproc +.else +; Find the best-fitting block of at least size XR +; if found, return with its address in WR and carry clear, YR is the block size, A +; is the contents of the flags word, and Y is 4 +; otherwise carry set and WR should be equal to HIMEM +; trashes ZR, which holds the size of the best candidate so far +.proc _find_free + stz ZR ; zero out best fit size + stz ZR+2 + jsr _chk_himem + bcc :+ ; if we have some heap, go see if anything free + rts ; otherwise just return with carry set +: pha ; make room on stack for "best" candidate + pha + bra lp ; enter loop +best: lda YR ; save block in WR as best block + sta ZR ; starting with size + lda YR+2 + sta ZR+2 + lda WR ; then with address + sta 1,s + lda WR+2 + sta 3,s +next: jsr _nextblk + bcs done ; when we run out of blocks +lp: ldy #$04 + lda [WR],y ; is it free? + bmi next ; nope, move on + jsr _blksize + lda YR+2 + cmp XR+2 + bne :+ + lda YR + cmp XR +: bcc next ; too big + lda ZR ; do we have a best candidate so far? + ora ZR+2 + beq best ; no, make this one the best + lda ZR+2 ; yes, see if this one is better + cmp YR+2 + bne :+ + lda ZR + cmp YR +: bcs best ; save as best (prefer higher blocks if =) + bra next ; otherwise go to next block +done: lda ZR + ora ZR+2 + beq none + lda ZR + sta YR + lda ZR+2 + sta YR+2 + pla + sta WR + pla + sta WR+2 + ldy #$04 + lda [WR],y + clc + rts +none: pla ; drop the block pointer + pla + sec + rts +.endproc +.endif + +; YR = WR-XR +.proc _wr_minus_xr + lda WR + sec + sbc XR + sta YR + lda WR+2 + sbc XR+2 + sta YR+2 + rts +.endproc + +; Grow heap to store at least XR bytes. Trashes WR and YR. +; return carry clear, HIMEM adjusted, and WR=new HIMEM if grow succeeded +; otherwise carry set and no changes to HIMEM +.proc _grow_heap + jsr _chk_himem + jsr _wr_minus_xr ; calculate bottom of reservation + lda YR ; then subtract header size + sec + sbc #.loword(HDR_SIZE) + sta YR + lda YR+2 + sbc #.hiword(HDR_SIZE) + sta YR+2 + lda DHERE ; now compare to DHERE+minimum break + clc + adc #.loword(MIN_BRK) + tay + lda DHERE+2 + adc #.hiword(MIN_BRK) + cmp YR+2 + bne :+ + tya + cmp YR +: bcs done ; would put us in the break, byebye + lda YR ; move YR to WR + sta WR + lda YR+2 + sta WR+2 + ldy #$04 ; offset of flags + lda #$0000 + sta [WR],y ; zero them (marked free) + ldy #SV_HIMEM+2 ; now get current HIMEM + lda [SYSVARS],y + pha ; save high byte on stack + dey + dey + lda [SYSVARS],y ; low byte... + ldy #$00 + sta [WR],y ; use it to make link + iny + iny + pla + sta [WR],y + ldy #SV_HIMEM+2 ; and set HIMEM to WR + lda WR+2 + sta [SYSVARS],y + dey + dey + lda WR + sta [SYSVARS],y + clc +done: rts +.endproc + +; Free memory pointed to by WR (at first byte of data, not marker) +; Also trashes XR and YR +; returns carry set if things went fine +; clear if double-free or freeing top of heap +.proc _free + lda WR + sec + sbc #.loword(HDR_SIZE) + sta WR + lda WR+2 + sbc #.hiword(HDR_SIZE) + sta WR+2 + ldy #$04 + lda [WR],y + bpl bad + and #$7FFF + sta [WR],y + jsr _collect + jsr _shrink_heap + sec + rts +bad: clc + rts +.endproc + +; Collect adjacent free blocks into larger blocks +; uses WR,XR,YR +.proc _collect + jsr _chk_himem + bcs done +loop: ldy #$04 + lda [WR],y + and #$8000 + beq :+ ; this block is free, peek at the next block +next: jsr _nextblk ; otherwise, it is used, move on + bcc loop +done: rts +: dey + dey + lda [WR],y ; get next block address into YR + sta YR+2 + dey + dey + lda [WR],y + sta YR + lda YR+2 + cmp MEM_TOP+2 ; and see if it is MEM_TOP + bne :+ + lda YR + cmp MEM_TOP +: bcs done ; if it is, we are done + ldy #$04 ; see if it is a free block + lda [YR],y + and #$8000 + bne next ; if not free, move on + dey ; if free, eat it by copying its pointer to ours + dey + lda [YR],y + sta [WR],y + dey + dey + lda [YR],y + sta [WR],y + bra loop ; check this block *again* to roll up more +.endproc + +; Shrink the heap by removing the first block, if it is free +.proc _shrink_heap +loop: jsr _chk_himem + bcs done + ldy #$04 ; see if free + lda [WR],y + and #$8000 + bne done ; nope, it's used, we are done + dey + dey + lda [WR],y ; get pointer high word + pha ; save on stack + dey + dey + lda [WR],y ; get low word + ldy #SV_HIMEM ; and write it out to HIMEM making it the new HIMEM + sta [SYSVARS],y + iny + iny + pla + sta [SYSVARS],y + bra loop ; go check it again +done: rts +.endproc + +.if 1 ; include fast memory move routines +; Memory move routines +; move XR bytes of memory from [WR] to [YR] + +; Move appropriately based +.proc _memmove + lda WR + cmp YR + lda WR+2 + sbc YR+2 + ; now carry is set if WR >= XR, move down in that case, otherwise move up + ; fall-through +.endproc + +; Move up if carry clear, down if carry set +.proc _memmove_c + php + lda XR ; first, pre-decrement XR + bne :+ + dec XR+2 + bpl :+ + plp + rts ; nothing to move +: dec XR + plp + bcc _memmove_up + ; fall-through if carry set +.endproc + +; adapted from 6502org.wikidot.com +.proc _memmove_dn +fromh = WR+2 +froml = WR +toh = YR+2 +tol = YR +sizeh = XR+2 +sizel = XR +md7 = ZR + phx + php + lda #$6B00 ; RTL + sta md7+2 + lda #$0054 ; MVN + sta md7 + sep #$21 ; 8-bit accumulator, set carry + .a8 + lda fromh + sta md7+2 + lda toh + sta md7+1 + lda sizeh + eor #$80 ; set v if sizeh is zero, clear v otherwise + sbc #$01 + rep #$30 + .a16 + .i16 ; already should be... + ldx froml + ldy tol + tya + cmp froml + bcc md3 ; if y < x then $FFFF-x < $FFFF-y + bra md4 + .a8 +md1: sta sizeh + eor #$80 ; set v if sizeh is zero, clear v otherwise + sbc #$01 + cpx #$0000 + bne md2 ; if x is not zero, then y must be + inc md7+2 + rep #$20 + .a16 + tya + bne md4 + sep #$20 + .a8 +md2: inc md7+1 + rep #$20 + .a16 +md3: txa +md4: eor #$FFFF ; A xor $FFFF = $FFFF - a + bvc md5 ; branch if sizeh is nonzero + cmp sizel + bcc md6 + lda sizel +md5: clc +md6: pha + phb + jsl f:_callzr + plb + pla + eor #$ffff ; a xor $ffff = $ffff - a = -1 - a + adc sizel + sta sizel ; sizel = sizel - 1 - a + sep #$20 + .a8 + lda sizeh ; update high byte of size + sbc #$00 + bcs md1 + rep #$30 + .a16 + .i16 + plp + plx + rts +.endproc + +.proc _memmove_up +fromh = WR+2 +froml = WR +toh = YR+2 +tol = YR +sizeh = XR+2 +sizel = XR +mu7 = ZR + phx + php + lda #$6B00 ; RTL + sta mu7+2 + lda #$0054 ; MVN + sta mu7 + sep #$21 ; 8-bit accumulator, set carry + .a8 + lda fromh + sta mu7+2 + lda toh + sta mu7+1 + lda sizeh + eor #$80 ; set v if sizeh is zero, clear v otherwise + sbc #$01 + rep #$30 + .a16 + .i16 + ldx froml + ldy tol + tya + cmp froml + bcs mu3 + bra mu4 + .a8 +mu1: sta sizeh + eor #$80 ; set v if size is zero, clear v otherwise + sbc #$01 + cpx #$FFFF + bne mu2 ; if x is not $FFFF, then y must be + dec mu7+2 + rep #$20 + .a16 + tya + cpy #$FFFF + bne mu4 + .a8 + sep #$20 +mu2: dec mu7+1 + rep #$20 + .a16 +mu3: txa +mu4: bvc mu5 ; branch if sizeh is nonzero + cmp sizel + bcc mu6 + lda sizel +mu5: clc +mu6: pha + phb + jsl f:_callzr + plb + pla + eor #$FFFF ; a xor $FFFF = $FFFF - a = -1 - a + adc sizel + sta sizel ; sizel = sizel - 1 - a + sep #$20 + .a8 + lda sizeh ; update high byte of size + sbc #$00 + bcs mu1 + rep #$30 + .a16 + .i16 + plp + plx + rts +.endproc + +.proc _callzr + sep #SHORT_A + .a8 + pha ; ( -- x ) + rep #SHORT_A + .a16 + pha ; ( x -- x x x ) + pha ; ( x x x -- x x x ah al ) + sep #SHORT_A + .a8 + lda #$00 ; ZR is in bank 0 + sta 5,s ; ( x x x ah al -- 0 x x ah al ) + rep #SHORT_A + .a16 + tdc + dec a + clc + adc #.loword(ZR) ; calculate actual location of ZR + sta 3,s ; ( 0 x x ah al -- 0 zrh zrl ah al ) + pla ; ( 0 zrh zrl ah al -- 0 zrh zrl ) + rtl ; ( 0 zrh zrl -- ) +.endproc +.endif diff --git a/asm/system.s b/asm/system.s new file mode 100644 index 0000000..fb7bc75 --- /dev/null +++ b/asm/system.s @@ -0,0 +1,207 @@ +; Main Forth system stuff. System variable declaration/initialization, system init, +; etc. + +; System variable numbers +; Be sure to update initialization table, below +DEF_SYSVAR 0, SV_STATE ; STATE +DEF_SYSVAR 1, SV_BASE ; BASE +DEF_SYSVAR 2, SV_OLDHERE ; (old here for exception during definition) +DEF_SYSVAR 3, SV_CURRENT ; $CURRENT +DEF_SYSVAR 4, SV_NLINE ; #LINE +DEF_SYSVAR 5, SV_NOUT ; #OUT +DEF_SYSVAR 6, SV_dCIB ; $CIB +DEF_SYSVAR 7, SV_PIN ; >IN +DEF_SYSVAR 8, SV_NIN ; #IN +DEF_SYSVAR 9, SV_SPAN ; SPAN +DEF_SYSVAR 10, SV_dPPTR ; $PPTR +DEF_SYSVAR 11, SV_HIMEM ; for alloc-mem & free-mem +DEF_SYSVAR 12, SV_CSBUF ; current interpretation temp string buffer +DEF_SYSVAR 13, SV_SBUF0 ; interpretation temp string buffer 1 of 2 +DEF_SYSVAR 14, SV_SBUF1 ; interpretation temp string buffer 2 of 2 +DEF_SYSVAR 15, SV_SOURCEID ; Input source ID, 0 = console, -1 = EVALUATE +DEF_SYSVAR 16, SV_dTIB ; terminal input buffer +DEF_SYSVAR 17, SV_dCSDEPTH ; Control-flow stack depth for temporary definitions +DEF_SYSVAR 18, SV_dSAVEHERE ; saved HERE for temporary definitions +DEF_SYSVAR 19, SV_pTMPDEF ; pointer to memory allocated for temp def +DEF_SYSVAR 20, SV_FORTH_WL ; Forth wordlist +DEF_SYSVAR 21, SV_FORTH_WL_XT ; Pointer to the "FORTH" word +DEF_SYSVAR 22, SV_ENV_WL ; last environmental word +DEF_SYSVAR 23, SV_ENV_WL_XT ; pointer to "$ENV?" word +DEF_SYSVAR 24, SV_dORDER ; Pointer to search order list +DEF_SYSVAR 25, SV_dCURDEF ; $CURDEF pointer to current colon, noname, etc. def +.if include_fcode +DEF_SYSVAR 26, SV_FCODE_IP ; FCode IP +DEF_SYSVAR 27, SV_FCODE_END ; FCode end, if true FCode evaluator will stop +DEF_SYSVAR 28, SV_FCODE_SPREAD ; Current FCode spread +DEF_SYSVAR 29, SV_FCODE_OFFSET ; if true, offsets are 16 bits +DEF_SYSVAR 30, SV_FCODE_FETCH ; XT of FCode fetch routine, usually C@ +DEF_SYSVAR 31, SV_FCODE_TABLES ; Pointer to FCode table pointers +DEF_SYSVAR 32, SV_FCODE_LAST ; Last FCode# in NEW-, NAMED-, or EXTERNAL-TOKEN +DEF_SYSVAR 33, SV_FCODE_DEBUG ; whether FCode debugging is enabled +.endif + +.proc _jtab +init: jmp __initialize +ui: jmp __ui +.endproc +.export _Forth_jmptab = _jtab +.export _Forth_initialize = _jtab::init +.export _Forth_ui = _jtab::ui + +; Table of initialization values for system variables +.proc SVARINIT + .dword 0 ; STATE 0 + .dword 16 ; BASE 4 + .dword 0 ; OLDHERE 8 for exception during definition + .dword 0 ; $CURRENT - WID of the compiler word list + .dword 0 ; #LINE 16 + .dword 0 ; #OUT 20 + .dword 0 ; $CIB 24 + .dword 0 ; >IN 28 + .dword 0 ; #IN 32 + .dword 0 ; SPAN 36 + .dword 0 ; $PPTR 40 + .dword 0 ; HIMEM 44 - for alloc-mem and free-mem + .dword 0 ; CSBUF + .dword 0 ; SBUF0 + .dword 0 ; SBUF1 + .dword 0 ; SOURCEID + .dword 0 ; $TIB + .dword 0 ; $CSDEPTH + .dword 0 ; $SAVEHERE + .dword 0 ; $>TMPDEF + .dword LAST_forth ; Forth wordlist + .dword FORTH ; "FORTH" word xt + .dword LAST_env ; environmental query wordlist + .dword ENVIRONMENTQ ; "ENVIRONMENT?" xt + .dword 0 ; search order pointer, if zero always uses Forth wordlist + .dword 0 ; $CURDEF +.if include_fcode + .dword 0 ; $FCODE-IP + .dword 0 ; $FCODE-END + .dword 1 ; $FCODE-SPREAD + .dword 0 ; $FCODE-OFFSET + .dword dRBFETCH ; $FCODE-FETCH + FCROM fc_romtab ; $FCODE-TABLES + .dword $7FF ; $FCODE-LAST last FCode# in NEW-, NAMED-, or EXTERNAL-TOKEN + .dword 0 ; FCODE-DEBUG? +.endif +.endproc +SYSVAR_INIT SVARINIT ; check size of initialize values + +.proc _call_sysif + sta ZR+2 ; save function # + stx ZR ; calculate stack depth + lda STK_TOP + sec + sbc ZR + lsr + lsr + tay + lda SYSIF+2 + sep #SHORT_A + pha + rep #SHORT_A + lda SYSIF + pha + lda ZR+2 ; get function # + rtl +.endproc + +; Enter with direct page register pointing to direct page reserved for the system +; with enough space for the variables in equates.inc +; and the following parameters on the '816 stack: +; system memory high (32-bit) +; system memory low (32-bit) +; stack top (16-bit) - this the bank 0 address just after first usable cell, relative to D +; stack bottom (16-bit) - this is the bank 0 address of the last usable cell, relative to D +; return stack top (16-bit) - return stack top, to be used by all routines +; except initialize +; system interface function (32-bit) - vector to basic I/O, etc. +; each stack must have at least 64 32-bit cells, a total of 256+ bytes each. +.proc __initialize + ; set up direct page + pla ; first, save caller address + sta WR + sep #SHORT_A + pla + sta WR+2 + rep #SHORT_A + pla ; get address of system interface function + sta SYSIF + pla + sta SYSIF+2 + lda SYSIF ; we are going call it via RTL, so decrement + bne :+ + dec SYSIF+2 +: dec SYSIF + pla + sta RSTK_TOP + sta RSTK_SAVE ; really a placeholder for completeness + pla + sta STK_BTM + pla + sta STK_TOP + pla + sta MEM_BTM + sta SYSVARS ; sysvars at memory bottom + pla + sta MEM_BTM+2 + sta SYSVARS+2 + pla + sta MEM_TOP + pla + sta MEM_TOP+2 + sep #SHORT_A ; restore caller address + lda WR+2 + pha + rep #SHORT_A + lda WR + pha + ; okay, direct page is set up from stack, do the rest of it + tsc ; switch to Forth return stack + sta SYS_RSTK + lda RSTK_TOP + tcs + phb ; save data bank for caller + phk + plb ; make sure we can move SYSVARS & OF816 + lda SYSVARS + clc + adc #.sizeof(SVARINIT) + sta DHERE + lda SYSVARS+2 + adc #$00 + sta DHERE+2 + ldy #0 +: lda SVARINIT,y + sta [SYSVARS],y + iny + iny + cpy #.sizeof(SVARINIT) + bcc :- + stz CATCHFLAG + ; Now do forth-based initialization + ldx STK_TOP + lda #SI_PRE_INIT + jsl _call_sysif ; hope it works, because we don't check! + ENTER + .dword ddSYSINIT + CODE + ; Remaining platform init platform if needed + lda #SI_POST_INIT + jsl _call_sysif ; carry flag propagates to RTL + plb ; restore caller data bank + lda SYS_RSTK ; and stack + tcs + rtl +.endproc + +.proc __ui + tsc + sta SYS_RSTK + ldx STK_TOP + jmp __doquit +.endproc + + diff --git a/build.sh b/build.sh new file mode 100755 index 0000000..47cffc8 --- /dev/null +++ b/build.sh @@ -0,0 +1,11 @@ +#!/bin/bash +cd `dirname ${0}` +PLATFORM="" +if [ -n "${1}" -a -d "platforms/${1}" ]; then + PLATFORM="${1}" +fi +export PLATFORM +echo ".define PLATFORM \"${PLATFORM}\"" > platform.inc +set -e -x +ca65 -I inc forth.s -l forth.lst + diff --git a/config.inc b/config.inc new file mode 100644 index 0000000..1c869ae --- /dev/null +++ b/config.inc @@ -0,0 +1,84 @@ +PLATFORM_INCLUDE "platform-config.inc" + +; *** options *** + +; Set this to a nonzero value if any code will run out of bank 0. If not set, then +; numeric literals <= $0000FFFF will use the "fast literal" mode, getting on the +; stack faster and using less memory. This should be set in the platform-specific +; config, and will only be set here if the platform config does not set it. +.if .defined(platform_fast_lits) + .out "platform_fast_lits set by platform config or cmdline" + .define no_fast_lits 0 +.else + .define no_fast_lits 1 +.endif + +; Set this to the size of the terminal input buffer. This will be dynamically allocated +; when the system starts. If command line history is enabled, several of these may be +; allocated at any given time. IEEE 1275 requires that it be 128 chars. +.define tib_size 128 + +; Set this to the number of bytes in the PAD. This is not required by IEEE 1275 and can +; be turned off with 0, saving a few bytes. ANSI X3J14-1994 requires at least 84 chars +; (bytes in our case) in the pad if it is present +.define pad_size $100 + +; Set this to the byte size of the WORD buffer. IEEE 1275 requires it to be (>=) 80. +; this buffer is shared with the pictured numeric output, which IEEE 1275 requires to +; be able to hold (>=) 66 characters. +.define word_buf_size 80 + +; Set this to a nonzero value to include FCode features (see IEEE 1275). This will +; cause the system size to increase by ~6K and also increase memory usage. +; The FCode evaluator supports most of the non-Device Tree FCode numbers, which can be +; added later via FCode or source in order to build an Open Firmware implementation on +; top of OF816. +.define include_fcode 1 + +; Set this to the number of word lists that may be in the search order. This number +; is required by ANSI X3J14-1994 to be 8 or greater if search order words are implemented. +; If this is set to 0, search order words are not included and about 1K is saved from +; the system size. +.define max_search_order 8 + +; IEEE 1275 specifies that certain words where interpretation semantics are not defined +; by ANSI X3J14-1994 must trigger a temporary definition outside of data space in order +; to provide interpretation semantics equivalent to what occurs in a compiled word. +; (e.g. '10 0 do i . loop' works outside of a definition) +; set this to the number of bytes allowed for such a temporary definition (512 =~ 128 +; cells). The memory used for a temporary definition is allocated from the heap, and is +; *not* bounds-checked during creation of the temporary definition. +.define max_tempdef 512 + +; SEE is a large complicated word. Omitting it saves 500 bytes. +.define include_see 1 + +; quotations are non-standard in ANS Forth and IEEE 1275, but may be useful +.define enable_quotations 1 + +; IEEE 1275 declines to identify what ENVIRONMENT? should return. ANS Forth gives +; specifics, but Forth 2012 deprecates detecting wordlists through environmental queries +; set this to 0 to include no environmental queries (ENVIRONMENT? always returns false) +; set this to 1 to include everything but the word list entries +; set this to 2 to include all of them +; note that the routines to access the environmental queries dictionary are not omitted, +; even when env_query_level is zero. As long as max_search_order is nonzero it is +; possible to add items to the environmental query dictionary +.define env_query_level 0 + +; UNALIGNED-[LW][!@] words are specified by IEEE 1275 for the user interface only (not +; FCode). In general these are redundant on the '816 because all accesses are unaligned, +; and in fact are defined as aliases to the normal versions of these. +; set this to 0 to exclude them, saving a few bytes. +.define unaligned_words 0 + +; *** debug options *** + +.define trace 0 ; requires emulator cooperation via WDM instruction +.define print_dict 0 ; output word addresses and XTs during assembly + +.if trace + .define no_headerless 1 +.else + .define no_headerless 0 ; set to 1 to compile headers for all words for debugging +.endif diff --git a/docs/getting_started.md b/docs/getting_started.md new file mode 100644 index 0000000..20808b8 --- /dev/null +++ b/docs/getting_started.md @@ -0,0 +1,228 @@ +# Getting Started + +## References + +[IEEE 1275-1994](http://www.openbios.org/data/docs/of1275.pdf) + +[ANS Forth X3.215-1994](http://lars.nocrew.org/dpans/dpans.htm) + +## Basics + +OF816 implements ANS Forth as described by IEEE 1275-1994, but lacking the +packages system and Device Tree features. It is advisable to read the above +documents as well as a Forth tutorial. + +### System Information + +OF816 is a portable Forth system. The bulk of the system is self-contained and +may be linked by itself and placed in the ROM or RAM of a target system +(restriction: code segments must not cross bank boundaries). The host system +can then configure and instantiate the interpreter via a jump table. Creating +a specific port allows the easy inclusion of platform-specific words and +routines, and allows leveraging of Forth components to implement the system +interface. + +The source code is logically broken down into config, macros, equates, the two +dictionaries, routines pertaining to interpretation/run-time, routines +pertaining to compilation, math library, memory management library, and FCode +evaluation. + +FCode may be created with the +[OpenBIOS FCode suite](https://www.openfirmware.info/FCODE_suite). Get the +FCode into ROM or RAM and use `` 1 byte-load`` to evaluate it. See the +W65C816SXB for example FCode to useful things, such as scan for and load +additonal FCode. + +### Included Ports + + * [W65C816SXB](https://wdc65xx.com/boards/w65c816sxb-engineering-development-system/). + * Apple IIgs. + +See the README files in each port's directory under /platforms for build & +installation instructions. + +## Configuration and Build + +The system may be configured by changing values in ``config.inc``. Each option +is described in that file. Note that changing the options may affect the +conformance statments that appear in this document, and/or the supported +features of the resulting system. + +OF816 is assembled and linked with the ``ca65`` assembler and ``ld65`` linker +from the [cc65 toolchain](https://github.com/cc65/cc65). To build a basic +cc65 object file with the basic system (no platform-specific code), execute +build.sh in the project root directory. + +Each platform port has their own method to build an image, see the directories +for each platform under ``platforms/``. + +## Porting/System Implementation + +See porting.md for instructions on how to port OF816 to your platform including +implementing the system interface. + +## Conformance + +### ANS Conformance + + * Providing the Core word set. + * Providing ``.(``, ``.R``, ``0<>``, ``0>``, ``2>R``, ``2R@``, ``:NONAME``, + ``<>``, ``?DO``, ``AGAIN``, ``CASE``, ``COMPILE,``, ``ENDCASE``, ``ENDOF``, + ``ERASE``, ``EXPECT``, ``FALSE``, ``HEX``, ``NIP``, ``PAD``, ``PARSE``, + ``PICK``, ``REFILL``, ``RESTORE-INPUT``, ``ROLL``, ``SAVE-INPUT``, + ``SOURCE-ID``, ``SPAN``, ``TO``, ``TRUE``, ``TUCK``, ``U.R``, ``U>``, + ``UNUSED``, ``VALUE``, ``WITHIN``, ``[COMPILE]``, and ``\`` from the Core + Extensions word set. + * Providing ``2CONSTANT``, ``D+``, ``D-``, ``D.R``, ``D>S``, ``DABS``, + ``DNEGATE``, and ``2ROT`` from thge Double-Number word set. + * Providing the Exception word set. + * Providing the Facility word set. + * Providing Programming-Tools word set. + * Providing ``;CODE``, ``AHEAD``, ``BYE``, ``CODE``, ``FORGET``, and ``STATE`` + from the Programming-Tools Extensions word set. + * Providing the Search Order word set. + * Providing ``-TRAILING``, ``BLANK``, ``CMOVE``, ``CMOVE>``, ``COMPARE``, + ``SEARCH``, and ``SLITERAL`` from the String word set. + +#### Implementation-defined Options + +See IEEE 1275-1994 section 2.4.3 "ANS Forth compatibility" for +implementation-defined options that are defined by that standard, with the +following exeptions/differences: + * Method of selection of console input and output device: Always defined by + the system interface. + * Packed strings are limited to 255 bytes as in Open Firmware. However, + counted strings may be larger and in practice most words that operate with + strings will accept strings of at least 65535 bytes. + * The maximum string length for ``ENVIRONMENT?`` queries is 128. + * The size of the console's input buffer is normally 128 but may be changed at + assembly time. + +Items from IEEE 1275-1994 that remain implementation-defined are defined in +OF816 as follows: + * Aligned address requirements: None. The 65C816 CPU does not have alignment + restrictions. Words that influence alignment or are affected by alignment + are no-ops or equivalent to their unaligned counterparts. + * Behavior of ``EMIT`` for non-graphic values: The character is passed to the + system interface to be handled in a manner defined by that interface. + * Control-flow stack: The parameter stack. + * Console input and output device: Defined by the system interface functions. + * Exception abort sequence: If ``CATCH`` is not used, an error message is + displayed and control is returned to the user via ``QUIT``. + * Input line terminator: CR (0x0D). + * Methods of dictionary compilation: appended to the data space afer the + previous definition. + * Methods of memory space management: There is one data space, it can be + allocated by traditional methods (``ALLOT``, etc.) from the bottom, and can + be allocated by ``ALLOC-MEM`` and freed by ``FREE-MEM`` from the top. + * Minimum search order: The minimum search order contains forth-wordlist. In + the event the search order is empty, the current compiler word list is + searched. + * Size of the scratch area who is addressed in ``PAD``: ``PAD`` is optional, + size set at assembly time. Dynamically moves as the dictionary grows. + * Non-standard words using ``PAD``: none. + * The current definition can be found after ``DOES>`` + * Source and format of display by ``SEE``: list of names and addresses. + Output not guaranteed to be correct/complete for built-in words. + +Other notes: + * ``WORD`` shares its buffer with the pictured numeric output. The normal + size meets IEEE 1275-1994, but it may be changed at assembly time. + +### Forth Interpreter IEEE 1275-1994 Conformance + +The command mode of the interpreter currently *does not* implement any of the +editing features described by IEEE 1725-1994. + +The following parts of IEEE 1275-1994 are implemented in the main interpreter +("user interface") of OF816: + * The entirety of section 7.3 "Forth command group." + * From section 7.4: ``RESET-ALL``. + * From section 7.5: ``SHOWSTACK``, ``NOSHOWSTACK``, ``WORDS``, ``SEE``, + ``(SEE)``. + +The following are not implemented: + * The entirety of section 7.4 "Administration command group." + * Most of section 7.5 except those noted above. + * The entirety of section 7.6. + * The entirety of section 7.7. + +### FCode Evaluator IEEE 1275-1994 Conformance + +#### Supported FCodes + +When FCode support is included, the following FCodes **are** available. +Generally, any caveats mentioned for words of the Forth interpreter apply to the +associated FCodes. + * All the FCodes from subsections 5.3.2.1, 5.3.2.2, 5.3.3.2, 5.3.3.3, 5.3.3.4. + * All the FCodes from subsection 5.3.3.1 *except* 0xC0 ``INSTANCE``. + * All the FCodes from subsection 5.3.3.3. + * 0x240 ``LEFT-PARSE-STRING`` and 0x11B ``PARSE-2INT`` from section 5.3.4. + * All the FCodes from subsections 5.3.7.1 and 5.3.7.2. + * All the FCodes from subsection 5.3.7.6 *except* 0x11F ``NEW-DEVICE``, 0x127 + ``FINISH-DEVICE``, and 0x23F ``SET-ARGS``. + +#### Unimplemented FCodes + +The following FCodes **are not** available: + * All the fcodes from section 5.3.4 ("Package access") *except* 0x240 + ``LEFT-PARSE-STRING`` and 0x11B ``PARSE-2INT``. + * All the fcodes from section 5.3.5 ("Property management"). + * All the FCodes from section 5.3.6 ("Display device management"). + * All the FCodes from subsections 5.3.7.3, 5.3.7.4, and 5.3.7.5. + * 0x11F ``NEW-DEVICE``, 0x127 ``FINISH-DEVICE``, and 0x23F ``SET-ARGS`` from + subsection 5.3.7.6. + +## Implementation-specific Words + + The following implementation-specific words are present: + + * ``$ENV?-WL`` ( -- wid ) return the wordlist for environmental queries. + * ``CICOMP`` ( addr1 addr2 u1 -- n1 ) case-insensitive version of ``COMP``. + * ``CONTEXT`` ( -- wid ) return the wordlist at the top of the search order. + * ``SEAL`` ( -- ) set the search order to contain only the current + ``CONTEXT``. + * ``$DIRECT`` ( -- a-addr ) provide the address of the 65C816 Direct Page used + by Forth. + * ``$FORGET`` ( xt -- ) attempt to forget the word at xt and subsequent + definitions. + * ``VOCABULARY`` ( "name"< > -- ) create a named vocabulary. + * ``$EMPTY-WL`` ( -- WID ) create a new completely empty wordlist without even + the root words. + * ``:TEMP`` ( ... -- ... ) start a temporary definition, execute it when ; is + executed. Exposes the underlying implementation for interpretation + semantics of various control-flow words such as ``DO``...``LOOP`` and + others. + * ``%DEFER``, ``%VARIABLE``, ``%BUFFER``, ``%VALUE`` (only when FCode is + enabled) ( -- ) compile the execution behavior of these types of words after + FCode executes a token-creating word. + * ``$2VALUE`` ( n1 n2 c-addr u -- ) create a ``2VALUE``. + * ``$VALUE`` ( n c-addr u -- ) create a ``VALUE`` + * ``$CREATE`` ( c-addr u -- ) make a create word. + * ``ACONCAT`` ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 ) assuming the stack + contains two strings held in memory allocated by ``ALLOC-MEM``, concatenate + them into a new string and ``FREE-MEM`` the originals. + * ``A"`` ( "string"<"> -- c-addr u ) parse string and place it in memory + allocated by ``ALLOC-MEM``. + * ``>NAME`` ( xt -- c-addr u ) find name or text representation of xt. May + use the word/pictured numeric output buffer. + * ``>LINK`` ( xt -- c-addr ) find link field of xt, 0 if none (noname). + * ``$BYTE-EXEC`` ( addr xt -- ) (only when FCode is enabled) evaluate FCode at + addr, fetching with xt. Do not save or restore evaluator state + (cf. ``BYTE-LOAD``). + * ``SQRTREM`` ( u1 -- u2 u3 ) calculate closest integer root less than or + equal to the actual square root of u1, leaving u3 as the remainder. + * ``$TMPSTR`` ( c-addr1 u1 -- c-addr2 u2 ) copy string into the next temporary + string buffer and return the copy. This exposes the underlying + implementation of interpretation semantics for ``S"`` and ``"``. + * ``$SYSIF`` ( ... callnum -- ... ) make calls to the system-specific + interfacing. + * ``DEBUG-MEM`` ( -- ) display memory managed by ``ALLOC-MEM``/``FREE-MEM``. + * ``BSX`` ( byte -- n ) byte sign-extend + * ``WSX`` ( word -- n ) word sign-extend + * ``$MEMTOP`` ( -- addr ) variable holding top of memory (byte immediately + after data space) + * ``[:`` and ``;]`` [quotations](http://www.forth200x.org/quotations.txt). + * Others I probably forgot. + +Note that individual platform ports may provide their own additional words. diff --git a/docs/internals.md b/docs/internals.md new file mode 100644 index 0000000..3bb1196 --- /dev/null +++ b/docs/internals.md @@ -0,0 +1,262 @@ +# OF816 Internals + +## System Description + +OF816 is a portable direct-threaded ANS Forth system for the WDC 65C816 +processor. + +The system features 32-bit code and data cells, and implements a 32-bit virtual +address space (truncated to 24-bit physical addresses). + +## Code Organization + +The main file ``forth.s`` is the sole source file that is directly given to the +assembler. This file brings in all the other source via ca65's ``.include`` +directive. + +### Include Files + +#### ``config.inc`` + +In the top level directory, ``config.inc`` contains configuration +options for the build in the form of ca65 ``.define`` directives. + +#### ``platform.inc`` + +Additionally, when ``build.sh`` is executed it creates a ``platform.inc`` file +that sets the platform to build. ``PLATFORM`` is defined as a blank value if no +platform is given. Otherwise, if a platform is passed to ``build.sh`` and a +directory in ``platforms/`` exists that matches, ``PLATFORM`` will be set to +that value. + +#### ``inc/macros.inc`` + +Macros for the system are in this and include dictionary macros, +shortcut macros for common Forth operations (e.g. ``NEXT``), and other items. + +This also contains some system-specific equates and constants not included +in ``inc/equates.inc``. + +#### ``inc/equates.inc`` + +Contains general equates for the system, including direct page, system interface +function codes, compiler constants, characters, etc. + +### Source Code + +The non-platform source code is in ``asm/`` and contains the following files. + +#### ``asm/compiler.s`` + +Contains support routines related to the the Forth compiler and appending +to data space in general. + +#### ``asm/env-dictionary.s`` + +Contains the environmental queries dictionary. + +#### ``asm/fcode.s`` + +Contains most of the FCode support code, less a few items that end up in the +Forth dictionary. This code is assembled in the "FCode" segment. + +#### ``asm/forth-dictionary.s`` + +Contains all of the Forth dictionary, including headerless helper words. + +#### ``asm/interpreter.s`` + +Contains the inner interpreter and supporting code. + +#### ``asm/mathlib.s`` + +Contains routines for basic math operations that need to be used by native +code, as well as the integer multiplication and division routines. + +#### ``asm/memmgr.s`` + +Contains memory management routines, including the heap allocator and fast +memory move routines. + +#### ``asm/system.s`` + +Contains the system entry points, initial system variables, and system +interfacing routines. + +### Platform Files + +Each platform is expected to provide at least the following files when a build +is created for a specific platform. Other files may be included by these files. + +A platform will typically also have code that instantiates the interpreter and +is linked with the built ``forth.o`` as well as a linker configuration file. + +#### ``platform-config.inc`` + +If the platform allows for additional configuration defines, these should be +placed here. + +#### ``platform-lib.s`` + +This file should contain the necessary platform-specific code and will often +contain all system interfacing that occurs when the system is instantiated. + +#### ``platform-words.s`` + +This file should contain any additonal entries that are to appear in the Forth +dictionary. + +## Forth Interpreter + +For reference on the basic construction and operation of a Forth interpreter, +see _Threaded Interpretive Languages_ by R.G. Loeligern (Byte, 1981). + +### System Registers + +The Forth system interpreter registers are implemented as follows: + +**I** (IP): The Instruction register is implemented on the direct page as the +32-bit pointer **IP**. The IP always points to the byte immediately before the +next Forth code cell. + +**WA/CA**: Being a direct-threaded interpreter, word address and code address +are effectively the same. The WA/CA register in this system is ephemeral +in that the next code address to execute is typically held in the 65816 A+Y +registers and then the lower 24-bits pushed onto the stack and finally executed +via RTL. + +**RS**: The Forth return stack register is the 65816 stack register. + +**SP**: The Forth paramter stack register is the 65816 X register. + +**WR/XR/YR/ZR**: Direct-page working registers for use by primitives. + +### Main Inner Interpreter Routines + +The inner interpreter consists of the routines in ``interpreter.s`` that +explicitly implement the inner interpreter as well as all routines that support +execution of Forth code. + +The main portion of the inner interpreter consists of the following routines. + +**``_enter``**: enter (or nest) the Forth interpreter. + +This routine swaps the 24-bit return address on the 65816 return stack for the +32-bit Forth IP and begins interpreting Forth code cells. + +The net effect is that when entered via JSL, the old IP is saved, and the next +Forth code cell to be executed is immediately after the JSL instruction. + +Shortcut macro: ``ENTER``. + +**``_next``**: fetch and execute the next Forth code cell. This is the usual +method to exit Forth primitives. + +Shortcut macros: ``NEXT`` (same-segment/bank), ``LNEXT`` (different segment/ +bank). + +**``__next::run``**: Execute Forth code beginning with the Forth XT in the +65816 AY registers. + +Shortcut macros: ``RUN`` + +The Forth word ``EXECUTE`` is implemented (in pseudo-code) as: POP AY; RUN. + +**``_exit_next``**: Restore previous IP from return stack and execute the next +code cell. This is the usual method to exit Forth secondaries. + +Shortcut macro: ``EXIT``. + +**``_exit_code``**: Swap the 32-bit previous IP on the return stack with the +24 low bits of the Forth IP and resume native code execution via RTL. + +The net effect is to resume native code execution after this word is executed +as a Forth XT. + +Shortcut macro: ``CODE``. + +Multiple ``ENTER``s and ``CODE``s may be used to freely mix Forth and native +code. + +## Dictionary + +### Dictionary Format + +The dictionary format is as follows: + +``` ++---------+--------------------------------------------------------| +| Size | Use | ++---------+--------------------------------------------------------| +| 4 bytes | Link to previous word (0 if end of dictionary) | +| 1 byte | Name length + $80 (high bit always set) if $80, noname | +| n bytes | Name | +| 1 byte | Flags | +| m bytes | Code | ++---------+--------------------------------------------------------| + +Flags bits: ++-----+-------------------------------+ +| 7 | Immediate | +| 6 | Compile-only | +| 5 | Protected (not FORGETtable) | +| 4 | Trigger temporary definition | +| 3 | Smudged (not found in search) | +| 2-0 | unused | ++-----+-------------------------------+ +``` + +### Word Lists/WIDs + +WIDs are pointers to wordlist objects. + +A wordlist object consists of two cells. The first cell points to the head +(most recently-defined definition) of the wordlist. The second cell is either +0 or contains an XT, the name of which is used for the name of the wordlist +for display purposes (e.g. when ``ORDER`` is executed). Typically the XT's +execution semantics are to place the given wordlist at the top of the search +order. + +### Dictionary Macros + +``macros.inc`` provides macros for creating dictionaries/definitions. They are +not all documented here, but a brief overview is: + +A dictionary is begun with ``dstart `` and finished with ``dend``. + +In between are one or more definitioons created with ``dword`` or ``hword`` +and ``eword``. ``dword