; 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