RISC DISC 2

home *** CD-ROM | disk | FTP | other *** search

/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / motasm / examples_hc11_as11_FORTH11 < prev next >

Wrap

Text File | 1995-05-13 | 94.3 KB | 3,575 lines

* * * * FORTH11.ASM fig-FORTH for the Motorola MC68HC11A1 * * October 30, 1990 * * ****************************************************************************** * * Memory Map * * * $0000 - $00ff 68hc11 internal ram * * $1000 - $103F 68hc11 internal registers * * $2000 - $7FFF 8k RAM * * $E000 - $FFFF 8k EPROM w/FORTH and 68hc11 vectors * NAM FORTH * ****************************************************************************** * * forth interpreter/compiler * ****************************************************************************** * * * MEMTOP EQU $7FFF RAMTOP EQU $7600 OPTION EQU $1039 * * each disk buffer block is one 256 byte sector * with a 2 byte block id and a 2 byte null terminator * * 8 - 256 byte blocks = 2 - 1024 byte screens * NBLK EQU 8 MEMEND EQU 260*NBLK+RAMTOP * * * REGBS EQU $1000 ; start of registers BAUD EQU REGBS+$2B ; sci baud reg SCCR1 EQU REGBS+$2C ; sci control1 reg SCCR2 EQU REGBS+$2D ; sci control2 reg SCSR EQU REGBS+$2E ; sci status reg SCDAT EQU REGBS+$2F ; sci data reg PORTA EQU REGBS+$00 PACTL EQU REGBS+$26 TMSK2 EQU REGBS+$24 TFLG2 EQU REGBS+$25 * * * ****************************************************************************** * * zero page memory * ****************************************************************************** * N EQU $0000 ; scratch for (FIND),ENCLOSE,CMOVE * ; EMIT,KEY,SP@,SWAP,DOES>,COLD * * registers used by the FORTH virtual machine * W EQU $0020 ; instruction reg points to 6800 code IP EQU $0022 ; inst. pointer points to pointer to 6800 code RP EQU $0024 ; return stack pointer UP EQU $0026 ; pointer to base of current user@@s @@USER@@ table * ( altered during multitasking ) * * ****************************************************************************** * * system parameters initialized by COLD or WARM * names refer to FORTH words of similar ( no X ) name * ****************************************************************************** * ORG $2000 * UORIG RMB 6 ; user variables XSPZER RMB 2 ; initial top of data stack for user XRZERO RMB 2 ; initial top of return stack XTIB RMB 2 ; start of terminal input buffer XWIDTH RMB 2 ; name field width XWARN RMB 2 ; warning message mode (0 = no disc) XFENCE RMB 2 ; fence for FORGET XDP RMB 2 ; dictionary pointer XVOCL RMB 2 ; vocabulary linking XBLK RMB 2 ; disk block being accessed XIN RMB 2 ; scan pointer into the block XOUT RMB 2 ; cursor position XSCR RMB 2 ; disc screen being accessed XOFSET RMB 2 ; disc sector offset for multi disc XCONT RMB 2 ; last word in primary search vocab. XCURR RMB 2 ; last word in extensible vocabulary XSTATE RMB 2 ; interpret/compile mode flag XBASE RMB 2 ; number base for i/o numeric conversion XDPL RMB 2 ; decimal point place XFLD RMB 2 ; XCSP RMB 2 ; current stack pos, for compile checks XRNUM RMB 2 ; XHLD RMB 2 ; XDELAY RMB 2 ; carriage return delay count XCOLUM RMB 2 ; carriage width IOSTAT RMB 2 ; last acia status from read/write * * end of user table, start of common system variables * XUSE RMB 2 ; XPREV RMB 2 ; XTRACK RMB 2 ; ( 4 spares ! ) XSECTOR RMB 2 XDSTAT RMB 2 XBLOCK RMB 2 XBUFFER RMB 2 * * code here through REND is overwritten at time of cold * load. * FCB $C5 FCC 'FORT' FCB $C8 FDB NOOP-7 FORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 FCC '(C) Forth Interest Group, 1979' FCB $C4 FCC 'TAS' FCB $CB FDB FORTH-8 TASK FDB DOCOL,SEMIS REND EQU * ; first empty location in dictionary ****************************************************************************** * * * ****************************************************************************** ORG $E000 ; * * initialize * INIT SEI LDAA #$B3 STAA OPTION ; * * initialize sci for 9600 baud at 8.0 mhz * LDAA #$30 STAA BAUD ; baud register LDAA #$00 STAA SCCR1 LDAA #$0C STAA SCCR2 ; enable ****************************************************************************** * * cold entry * ****************************************************************************** ORIG NOP JMP CENT ****************************************************************************** * * warm entry * ****************************************************************************** NOP ; JMP WENT ; warm start * ; keeps current dictionary intact ****************************************************************************** * * startup parameters * ****************************************************************************** FDB $6811,0001 ; cpu and revision FDB 0 ; topmost word in FORTH vocabulary BACKSP FDB $08 ; backspace character for editing UPINIT FDB UORIG ; initial user area SINIT FDB RAMTOP-$100 ; initial top of data stack RINIT FDB RAMTOP-2 ; initial top of return stack FDB RAMTOP-$D0 ; terminal input buffer FDB 31 ; initial name field width FDB 0 ; initial warning mode (0 = no disc) FENCIN FDB REND ; initial fence DPINIT FDB REND ; cold start value for DP VOCINT FDB FORTH+8 ; cold start value for VOC-LINK COLINT FDB 80 ; initial terminal carriage width DELINT FDB 4 ; initial carriage return delay * * * PULABX PULA ; get data word PULB STABX STD 0,X ; store at address BRA NEXT * GETX LDD 0,X ; get data from address PUSHBA PSHB ; and save on stack PSHA * *=================== the virtual machine ===================================== * NEXT LDX IP INX ; pre-increment mode INX STX IP NEXT2 LDX 0,X ; get W which points to CFA of word to be done NEXT3 STX W NEXT5 LDX 0,X ; get VECT which points to executable code JMP 0,X ; and then do it NOP * *============================================================================= * *=======>> 1 << LIT ; primitive * FCB $83 FCC 'LI' FCB $D4 FDB 0 ; link of zero to terminate dictionary scan LIT FDB *+2 LDX IP ; get instruction pointer INX INX STX IP ; x points to next instruction LDD 0,X ; next instruction is 16 bit literal JMP PUSHBA ; so push it on stack * *=======>> 3 << EXECUTE ; primitive * FCB $87 FCC 'EXECUT' FCB $C5 FDB LIT-6 EXEC FDB *+2 TSX ; move stack pointer to x LDX 0,X ; get code field address (CFA) INS ; pop stack INS JMP NEXT3 ; go execute word that cfa points to * *=======>> 4 << BRANCH * FCB $86 FCC 'BRANC' FCB $C8 FDB EXEC-10 BRAN FDB ZBYES ; go do unconditional branch * *=======>> 5 << 0BRANCH ; primitive * FCB $87 FCC '0BRANC' FCB $C8 FDB BRAN-9 ZBRAN FDB *+2 PULA ; get flag PULB ABA ; add together to see if zero BNE ZBNO ; a and b are not zero - don@@t branch BCS ZBNO ; if overflow a and b are not zero ! * * flag is false ( zero ) - branch * ZBYES LDX IP ; code is shared with BRANCH, (+LOOP),(LOOP) LDD 2,X ; get offset ADDD IP ; add offset to instruction pointer STD IP ; save it JMP NEXT ; go branch ! * * flag is true ( non-zero ) - don@@t branch * ZBNO LDX IP ; no branch. this code is shared with (+LOOP),(LOOP) INX ; jump over branch delta INX STX IP ; save pointer JMP NEXT ; go do next instruction * *=======>> 6 << (LOOP) ; primitive * FCB $86 FCC '(LOOP' FCB $A9 FDB ZBRAN-10 XLOOP FDB *+2 CLRA ; upper 8 is zero LDAB #1 ; get set to increment counter by 1 BRA XPLOP2 ; go steal other guy@@s code * *=======>> 7 << (+LOOP) ; primitive * FCB $87 FCC '(+LOOP' FCB $A9 FDB XLOOP-9 XPLOOP FDB *+2 ; +LOOP has an unsigned loop counter PULA ; get increment value PULB XPLOP2 TSTA ; check if forward or backward looping BPL XPLOF ; forward looping LDX RP ADDD 2,X STD 2,X SEC SBCB 5,X SBCA 4,X BPL ZBYES BRA XPLONO ; fall thru * XPLOF NOP LDX RP ADDD 2,X STD 2,X * BSR XPLOPS SUBD 4,X BMI ZBYES XPLONO INX ; done, don@@t branch back INX INX INX STX RP BRA ZBNO * *=======>> 8 << (DO) ; primitive * FCB $84 FCC '(DO' FCB $A9 FDB XPLOOP-10 XDO1 FDB *+2 ; this is the RUN-TIME DO, not the COMPILING DO LDX RP ; get copy of return pointer DEX DEX DEX DEX STX RP ; PULA ; pull data word off stack PULB STD 2,X ; save on return stack PULA ; pull ??? off stack PULB STD 4,X ; save on return stack JMP NEXT * *=======>> 9 << I ; primitive * FCB $81 ; I FCB $C9 FDB XDO1-7 I FDB *+2 LDX RP ; looks like I is kept on return stack INX INX JMP GETX ; * *=======>> 10 << DIGIT * FCB $85 FCC 'DIGI' FCB $D4 FDB I-4 DIGIT FDB *+2 ; legal input range is 0-9, A-Z TSX ; copy stack pointer to x LDAA 3,X SUBA #$30 ; ascii zero BMI DIGIT2 ; if less than @@0@@, ILLEGAL CMPA #$0A BMI DIGIT0 ; if @@9@@ or less CMPA #$11 BMI DIGIT2 ; if less than "A" CMPA #$2B BPL DIGIT2 ; if greater than "Z" SUBA #7 ; translate "A" thru "F" DIGIT0 CMPA 1,X BPL DIGIT2 ; if not less than the base LDAB #1 ; set flag STAA 3,X ; store digit DIGIT1 STAB 1,X ; store the flag JMP NEXT DIGIT2 CLRB ; INS INS ; pop bottom number TSX ; STAB 0,X ; make sure both bytes are 00 BRA DIGIT1 * * the word format in the dictionary is : * * NFA char-count + 80 lowest address * char 1 * char 2 * * char n + $80 * * LFA link high byte \___ point to previous word * link low byte / * * CFA CFA high byte \___ point to 6800 code * CFA low byte / * * PFA parameter fields * " " * " " * * *=======>> 11 << (FIND) * FCB $86 FCC '(FIND' FCB $A9 FDB DIGIT-8 PFIND FDB *+2 NOP NOP PD EQU N ; pointer to dict word being checked PA0 EQU N+2 PA EQU N+4 PC EQU N+6 LDX #PD LDAB #4 PFIND0 PULA ; loop to get arguments off stack STAA 0,X INX DECB BNE PFIND0 LDX PD PFIND1 LDAB 0,X ; get count dict count STAB PC ANDB #$3F INX STX PD ; update PD LDX PA0 LDAA 0,X ; get count from arg INX STX PA ; initialize PA CBA ; compare lengths BNE PFIND4 PFIND2 LDX PA LDAA 0,X INX STX PA LDX PD LDAB 0,X INX STX PD TSTB ; is dict entry neg. ? BPL PFIND8 ANDB #$7F ; clear sign CBA BEQ FOUND PFIND3 LDX 0,X ; get new link BNE PFIND1 ; continue if link not = 0 * * not found * CLRA CLRB JMP PUSHBA PFIND8 CBA BEQ PFIND2 PFIND4 LDX PD PFIND9 LDAB 0,X ; scan forward to end of this name INX BPL PFIND9 ; read until bit 7 is found set BRA PFIND3 * * * FOUND LDD PD ; compute CFA ADDD #4 ; PSHB ; and push on stack PSHA LDAA PC ; push dictionary count PSHA CLRA PSHA ; with upper 8 bits zero LDAB #1 ; construct a true flag JMP PUSHBA ; and go push on stack * *=======>> 12 << ENCLOSE * FCB $87 FCC 'ENCLOS' FCB $C5 FDB PFIND-9 * * FC means offset (bytes) to first character of next word * EW " " @@@ to end of word * NC " " @@@ to next character to start next enclose at * ENCLOS FDB *+2 INS PULB ; now, get low byte, for an 8 bit delimiter TSX ; copy stack pointer LDX 0,X ; get address to start enclose at CLR N ; clear counter * * wait for a non-delimiter or a NUL * ENCL2 LDAA 0,X ; get a character BEQ ENCL6 ; found null CBA ; is it the delimiter ? BNE ENCL3 ; yes INX ; no INC N ; bump count BRA ENCL2 ; try it again * * found first character. Push FC * ENCL3 LDAA N ; found first character PSHA ; push count CLRA PSHA ; push $00 * * wait for a delimiter or a NUL * ENCL4 LDAA 0,X ; get another character BEQ ENCL7 ; it@@s a null CBA ; check for a delimiter BEQ ENCL5 ; yes - it is the delimiter INX ; no INC N ; increment count BRA ENCL4 ; see if we can find it somewhere * * found end of word * ENCL5 LDAB N ; get count CLRA ; upper 8 = 0 PSHB ; push EW PSHA * * advance and push NC * INCB ; increment JMP PUSHBA * * found NUL before non-delimiter, therefore there is no word * ENCL6 LDAB N ; found NUL PSHB PSHA INCB BRA ENCL7+2 ; * * found NUL following the word instead of SPACE * ENCL7 LDAB N ; PSHB PSHA ENCL8 LDAB N ; JMP PUSHBA * * the next 4 words call system dependent I/O subroutines * which are listed after "-->" in the dictionary * *=======>> 13 << EMIT * FCB $84 FCC 'EMI' FCB $D4 FDB ENCLOS-10 EMIT FDB *+2 PULA ; get data PULA STAB N ; save B STX N+1 ; save X * EMIT1 LDAB SCSR ; read status BITB #$40 BEQ EMIT1 ; ANDA #$7F ; mask parity STAA SCDAT ; send character LDAB N ; recover B & X LDX N+1 JMP NEXT ; * *=======>> 14 << KEY * FCB $83 FCC 'KE' FCB $D9 FDB EMIT-7 KEY FDB *+2 STAB N ; save b and x STX N+1 * INSCI LDAA SCSR ; read status reg ANDA #$20 BEQ INSCI ; jump if rdrf=0 LDAA SCDAT ; read data register ANDA #$7F ; mask parity LDAB N ; restore b and x LDX N+1 PSHA ; push data byte CLRA PSHA ; push a zero byte JMP NEXT * *=======>> 15 << ?TERMINAL * FCB $89 FCC '?TERMINA' FCB $CC FDB KEY-6 QTERM FDB *+2 LDAA SCSR ANDA #$20 ; rdrf set ? BEQ QTERM1 LDAA SCDAT ; yes - read data to clear it LDAA #$01 ; flag = true BRA QTERM2 QTERM1 CLRA ; flag = false QTERM2 CLRB JMP PUSHBA ; stack the flag * *=======>> 16 << CR * FCB $82 FCC 'C' FCB $D2 FDB QTERM-12 CR FDB *+2 LDAA #$D ; carriage return CR1 LDAB SCSR ; read status BITB #$40 BEQ CR1 ; loop until tC=1 ANDA #$7F ; mask parity STAA SCDAT ; send character LDAA #$A ; line feed CR2 LDAB SCSR ; read status BITB #$40 BEQ CR2 ; loop until tC=1 ANDA #$7F ; mask parity STAA SCDAT ; send character JMP NEXT * *=======>> 17 << CMOVE ; source, destination, count * FCB $85 FCC 'CMOV' FCB $C5 FDB CR-5 CMOVE FDB *+2 ; LDX #N ; find temp storage area LDAB #6 ; byte count * * n = count ; n+2 = destination ; n+4 = source * CMOV1 PULA ; pop 6 bytes off stack STAA 0,X ; move parameters to scratch area INX ; DECB BNE CMOV1 CMOV2 LDD N ; get count SUBD #1 ; subtract one STD N ; save count BCS CMOV3 ; we be done ? LDX N+4 ; get source address LDAA 0,X ; get source data INX STX N+4 ; save source pointer LDX N+2 ; get destination pointer STAA 0,X ; write it to destination INX STX N+2 ; save destination pointer _CMOV2 BRA CMOV2 CMOV3 JMP NEXT * *=======>> 18 << U* * FCB $82 FCC 'U' FCB $AA FDB CMOVE-8 USTAR FDB *+2 LDAA #16 ; bits/word counter PSHA CLRA CLRB TSX USTAR2 ROR 3,X ; shift multiplier ROR 4,X DEC 0,X ; done ? BMI USTAR4 ; yes BCC USTAR3 ADDD 1,X USTAR3 RORA RORB ; shift result BRA USTAR2 USTAR4 INS ; dump counter INS INS JMP PUSHBA ; leave high word * * * *=======>> 19 << U/ * FCB $82 FCC 'U' FCB $AF FDB USTAR-5 USLASH FDB *+2 LDAA #17 PSHA TSX LDD 3,X USL1 CMPA 1,X BHI USL3 BCS USL2 CMPB 2,X BCC USL3 USL2 CLC BRA USL4 USL3 SUBD 1,X SEC USL4 ROL 6,X ROL 5,X DEC 0,X BEQ USL5 ROLB ROLA BCC USL1 BRA USL3 USL5 INS INS INS INS INS JMP SWAP+4 ; reverse quotient and remainder * *=======>> 20 << AND * FCB $83 FCC 'AN' FCB $C4 FDB USLASH-5 AND FDB *+2 PULA ; pop data off stack PULB TSX ; copy stack pointer ANDB 1,X ; AND the D acc with data on stack ANDA 0,X JMP STABX ; go save result * *=======>> 21 << OR * FCB $82 FCC 'O' FCB $D2 FDB AND-6 OR FDB *+2 PULA ; pop data off stack PULB TSX ; copy stack pointer ORAB 1,X ; OR the D acc with data on stack ORAA 0,X JMP STABX ; go save result * *=======>> 22 << XOR * FCB $83 FCC 'XO' FCB $D2 FDB OR-5 XOR FDB *+2 PULA ; pop data PULB TSX ; copy stack pointer EORB 1,X ; XOR the D acc with data on stack EORA 0,X JMP STABX ; go save result * * SP@ * FCB $83 FCC 'SP' FCB $C0 FDB XOR-6 SPAT FDB *+2 TSX ; copy stack pointer STX N ; save in scratch area LDX #N ; this doesn@@t make sense to me !! JMP GETX * *=======>> 24 << SP! * FCB $83 FCC 'SP' FCB $A1 FDB SPAT-6 SPSTOR FDB *+2 LDX UP ; get user pointer LDX XSPZER-UORIG,X ; find initialization value for sp TXS ; watch it! X and S are not equal JMP NEXT * *=======>> 25 << RP! * FCB $83 FCC 'RP' FCB $A1 FDB SPSTOR-6 RPSTOR FDB *+2 LDX RINIT ; initialize from rom constant STX RP ; save new return pointer JMP NEXT * *=======>> 26 << ;S * FCB $82 FCC ';' FCB $D3 FDB RPSTOR-6 SEMIS FDB *+2 LDX RP ; get return pointer INX INX STX RP ; LDX 0,X ; get address we have just finished JMP NEXT+2 ; increment the return address & do next word * *=======>> 27 << LEAVE * FCB $85 FCC 'LEAV' FCB $C5 FDB SEMIS-5 LEAVE FDB *+2 LDX RP ; LDD 2,X STD 4,X ; JMP NEXT * *=======>> 28 << >R * FCB $82 FCC '>' FCB $D2 FDB LEAVE-8 TOR FDB *+2 LDX RP ; find return stack DEX ; make room on return stack DEX STX RP ; PULA ; pop data PULB STD 2,X ; and save on return stack JMP NEXT * *=======>> 29 << R> * FCB $82 FCC 'R' FCB $BE FDB TOR-5 FROMR FDB *+2 LDX RP ; find return stack LDD 2,X ; get data INX ; toss out 2 bytes INX STX RP ; save pointer JMP PUSHBA ; push data back on stack * *=======>> 30 << R * FCB $81 ; R FCB $D2 FDB FROMR-5 R FDB *+2 LDX RP ; find pointer INX INX JMP GETX ; copy data and push on data stack * *=======>> 31 << 0= * FCB $82 FCC '0' FCB $BD FDB R-4 ZEQU FDB *+2 TSX ; copy stack pointer CLRA CLRB LDX 0,X ; now get data off stack BNE ZEQU2 ; not zero so leave false flag INCB ; it is zero so leave true flag ZEQU2 TSX ; JMP STABX ; save flag * *=======>> 32 << 0< * FCB $82 FCC '0' FCB $BC FDB ZEQU-5 ZLESS FDB *+2 TSX ; copy stack pointer LDAA #$80 ; check the sign bit ANDA 0,X ; BEQ ZLESS2 CLRA ; if negative LDAB #1 ; leave true flag as it is less than zero JMP STABX ZLESS2 CLRB ; leave false - it@@s greater than zero JMP STABX * *=======>> 33 << + * FCB $81 ; + FCB $AB FDB ZLESS-5 PLUS FDB *+2 PULA ; pop data PULB TSX ; copy stack pointer ADDD 0,X ; add two words JMP STABX ; and leave result on stack * *=======>> 34 << D+ * FCB $82 FCC 'D' FCB $AB FDB PLUS-4 DPLUS FDB *+2 TSX ; copy stack pointer CLC LDAB #4 ; double word is 4 bytes DPLUS2 LDAA 3,X ; point to byte of bottom ADCA 7,X ; add to byte of top STAA 7,X ; save result DEX ; DECB ; knock down count BNE DPLUS2 ; do until 4 bytes complete INS ; toss 2 words INS INS INS JMP NEXT ; * *=======>> 35 << MINUS ; change sign of word on stack * FCB $85 FCC 'MINU' FCB $D3 FDB DPLUS-5 MINUS FDB *+2 TSX ; copy stack pointer NEG 1,X ; negate bottom byte BCS MINUS2 NEG 0,X ; negate upper byte BRA MINUS3 MINUS2 COM 0,X ; MINUS3 JMP NEXT * *=======>> 36 << DMINUS ; change sign of double word on stack * FCB $86 FCC 'DMINU' FCB $D3 FDB MINUS-8 DMINUS FDB *+2 TSX ; copy stack pointer COM 0,X COM 1,X COM 2,X NEG 3,X BNE DMINX ; figure this out later INC 2,X BNE DMINX INC 1,X BNE DMINX INC 0,X DMINX JMP NEXT * *=======>> 37 << OVER * FCB $84 FCC 'OVE' FCB $D2 FDB DMINUS-9 OVER FDB *+2 TSX ; copy stack pointer LDD 2,X ; get second word on stack JMP PUSHBA ; and copy it to top * *=======>> 38 << DROP * FCB $84 FCC 'DRO' FCB $D0 FDB OVER-7 DROP FDB *+2 INS ; knock sp twice INS ; to remove top item froom stack JMP NEXT * *=======>> 39 << SWAP * FCB $84 FCC 'SWA' FCB $D0 FDB DROP-7 SWAP FDB *+2 PULA ; get top item of stack PULB TSX ; copy sp LDX 0,X ; copy second item INS INS PSHB ; save top item as second item PSHA STX N ; now go save second as top LDX #N JMP GETX * *=======>> 40 << DUP * FCB $83 FCC 'DU' FCB $D0 FDB SWAP-7 DUP FDB *+2 PULA ; get data PULB PSHB ; push data PSHA JMP PUSHBA ; push it again to duplicate * *=======>> 41 << +! * FCB $82 FCC '+' FCB $A1 FDB DUP-6 PSTORE FDB *+2 TSX ; copy stack pointer LDX 0,X ; get address INS INS PULA ; get data from stack PULB ADDB 1,X ; add and store low byte STAB 1,X ADCA 0,X ; add and store high byte STAA 0,X JMP NEXT * *=======>> 42 << TOGGLE * FCB $86 FCC 'TOGGL' FCB $C5 FDB PSTORE-5 TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE FDB SEMIS * *=======>> 43 << @ * FCB $81 ; @ FCB $C0 FDB TOGGLE-9 AT FDB *+2 TSX ; copy sp LDX 0,X ; get address INS INS JMP GETX ; get 16 bit data from address * *=======>> 44 << C@ * FCB $82 FCC 'C' FCB $C0 FDB AT-4 CAT FDB *+2 TSX ; copy sp LDX 0,X ; get address CLRA ; make upper byte zero LDAB 0,X ; get 8 bit data from address INS INS JMP PUSHBA ; and save on stack * *=======>> 45 << ! * FCB $81 ; ! FCB $A1 FDB CAT-5 STORE FDB *+2 TSX LDX 0,X ; get address INS INS JMP PULABX ; then get data and store at addr * *=======>> 46 << C! * FCB $82 FCC 'C' FCB $A1 FDB STORE-4 CSTORE FDB *+2 TSX ; copy stack pointer LDX 0,X ; get address INS INS INS PULB ; get 8 bit data STAB 0,X ; and store it JMP NEXT * *=======>> 47 << : * FCB $C1 FCB $BA FDB CSTORE-5 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE FDB CREATE,RBRAK FDB PSCODE * * here is the IP pusher for allowing nested words * in the virtual machine * ( ;S is the equivalent un-nester) * * DOCOL LDX RP ; make room in the stack DEX DEX STX RP LDD IP ; get instruction pointer STD 2,X ; store address of the high level word LDX W ; get first sub-word of that definition JMP NEXT+2 ; and execute it * * >> 48 << ; * FCB $C1 ; immediate code FCB $BB FDB COLON-4 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK FDB SEMIS * *=======>> 49 << CONSTANT * FCB $88 FCC 'CONSTAN' FCB $D4 FDB SEMI-4 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE DOCON LDX W ; pointer LDD 2,X ; get constant data JMP PUSHBA ; and save it * *=======>> 50 << VARIABLE * FCB $88 FCC 'VARIABL' FCB $C5 FDB CON-11 VAR FDB DOCOL,CON,PSCODE DOVAR LDD W ; pointer to parameter field ADDD #2 ; A:B now contain the address of the variable JMP PUSHBA * *=======>> 51 << USER * FCB $84 FCC 'USE' FCB $D2 FDB VAR-11 USER FDB DOCOL,CON,PSCODE DOUSER LDX W ; get offset into user@@s table LDD 2,X ADDD UP JMP PUSHBA ; push address of user@@s variable * *=======>> 52 << 0 * FCB $81 ; 0 FCB $B0 FDB USER-7 ZERO FDB DOCON FDB 0000 * *=======>> 53 << 1 * FCB $81 ; 1 FCB $B1 FDB ZERO-4 ONE FDB DOCON FDB 1 * *=======>> 54 << 2 * FCB $81 ; 2 FCB $B2 FDB ONE-4 TWO FDB DOCON FDB 2 * *=======>> 55 << 3 * FCB $81 ;3 FCB $B3 FDB TWO-4 THREE FDB DOCON FDB 3 * *=======>> 56 << BL * FCB $82 FCC 'B' FCB $CC FDB THREE-4 BL FDB DOCON ; ascii blank FDB $20 * *=======>> 57 << FIRST * FCB $85 FCC 'FIRS' FCB $D4 FDB BL-5 FIRST FDB DOCON FDB RAMTOP ; * *=======>> 58 << LIMIT ; the end of memory +1 * FCB $85 FCC 'LIMI' FCB $D4 FDB FIRST-8 LIMIT FDB DOCON FDB MEMEND ; * *=======>> 59 << B/BUF ; 256 bytes/buffer * FCB $85 FCC 'B/BU' FCB $C6 FDB LIMIT-8 BBUF FDB DOCON FDB 256 * *=======>> 60 << B/SCR ; blocks/screen = 1024/(B/BUF) = 4 * ; FCB $85 FCC 'B/SC' FCB $D2 FDB BBUF-8 BSCR FDB DOCON FDB 4 * *=======>> 61 << +ORIGIN * FCB $87 FCC '+ORIGI' FCB $CE FDB BSCR-8 PORIG FDB DOCOL,LIT,ORIG,PLUS FDB SEMIS * *=======>> 62 << S0 * FCB $82 FCC 'S' FCB $B0 FDB PORIG-10 SZERO FDB DOUSER FDB XSPZER-UORIG * *=======>> 63 << R0 * FCB $82 FCC 'R' FCB $B0 FDB SZERO-5 RZERO FDB DOUSER FDB XRZERO-UORIG * *=======>> 64 << TIB * FCB $83 FCC 'TI' FCB $C2 FDB RZERO-5 TIB FDB DOUSER FDB XTIB-UORIG * *=======>> 65 << WIDTH * FCB $85 FCC 'WIDT' FCB $C8 FDB TIB-6 WIDTH FDB DOUSER FDB XWIDTH-UORIG * *=======>> 66 << WARNING * FCB $87 FCC 'WARNIN' FCB $C7 FDB WIDTH-8 WARN FDB DOUSER FDB XWARN-UORIG * *=======>> 67 << FENCE * FCB $85 FCC 'FENC' FCB $C5 FDB WARN-10 FENCE FDB DOUSER FDB XFENCE-UORIG * *=======>> 68 DP pointer to first free * byte at end of dictionary * FCB $82 FCC 'D' FCB $D0 FDB FENCE-8 DP FDB DOUSER FDB XDP-UORIG * *=======>> 68.5 << VOC-LINK * FCB $88 FCC 'VOC-LIN' FCB $CB FDB DP-5 VOCLIN FDB DOUSER FDB XVOCL-UORIG * *=======>> 69 << BLK * FCB $83 FCC 'BL' FCB $CB FDB VOCLIN-11 BLK FDB DOUSER FDB XBLK-UORIG * *=======>> 70 << IN ; scan pointer for input line buffer * FCB $82 FCC 'I' FCB $CE FDB BLK-6 IN FDB DOUSER FDB XIN-UORIG * *=======>> 71 << OUT * FCB $83 FCC 'OU' FCB $D4 FDB IN-5 OUT FDB DOUSER FDB XOUT-UORIG * *=======>> 72 << SCR * FCB $83 FCC 'SC' FCB $D2 FDB OUT-6 SCR FDB DOUSER FDB XSCR-UORIG * *=======>> 73 << OFFSET * FCB $86 FCC 'OFFSE' FCB $D4 FDB SCR-6 OFSET FDB DOUSER FDB XOFSET-UORIG * *=======>> 74 << CONTEXT ; points to pointer to * ; vocabulary to search first FCB $87 FCC 'CONTEX' FCB $D4 FDB OFSET-9 CONTXT FDB DOUSER FDB XCONT-UORIG * *=======>> 75 << CURRENT ; points to pointer to * ; vocabulary being extended FCB $87 FCC 'CURREN' FCB $D4 FDB CONTXT-10 CURENT FDB DOUSER FDB XCURR-UORIG * *=======>> 76 << STATE ; 1 if compiling, 0 if not * FCB $85 FCC 'STAT' FCB $C5 FDB CURENT-10 STATE FDB DOUSER FDB XSTATE-UORIG * *=======>> 77 << BASE ; number base for all input and output * FCB $84 FCC 'BAS' FCB $C5 FDB STATE-8 BASE FDB DOUSER FDB XBASE-UORIG * *=======>> 78 << DPL * FCB $83 FCC 'DP' FCB $CC FDB BASE-7 DPL FDB DOUSER FDB XDPL-UORIG * *=======>> 79 << FLD * FCB $83 FCC 'FL' FCB $C4 FDB DPL-6 FLD FDB DOUSER FDB XFLD-UORIG * *=======>> 80 << CSP * FCB $83 FCC 'CS' FCB $D0 FDB FLD-6 CSP FDB DOUSER FDB XCSP-UORIG * *=======>> 81 << R# * FCB $82 FCC 'R' FCB $A3 FDB CSP-6 RNUM FDB DOUSER FDB XRNUM-UORIG * *=======>> 82 << HLD * FCB $83 FCC 'HL' FCB $C4 FDB RNUM-5 HLD FDB DOCON FDB XHLD * *=======>> 82.5 << COLUMNS ; line width of terminal * FCB $87 FCC 'COLUMN' FCB $D3 FDB HLD-6 COLUMS FDB DOUSER FDB XCOLUM-UORIG * *=======>> 83 << 1+ * FCB $82 FCC '1' FCB $AB FDB COLUMS-10 ONEP FDB DOCOL,ONE,PLUS FDB SEMIS * *=======>> 84 << 2+ * FCB $82 FCC '2' FCB $AB FDB ONEP-5 TWOP FDB DOCOL,TWO,PLUS FDB SEMIS * *=======>> 85 << HERE * FCB $84 FCC 'HER' FCB $C5 FDB TWOP-5 HERE FDB DOCOL,DP,AT FDB SEMIS * *=======>> 86 << ALLOT * FCB $85 FCC 'ALLO' FCB $D4 FDB HERE-7 ALLOT FDB DOCOL,DP,PSTORE FDB SEMIS * *=======>> 87 << , ( this is a comma ) * FCB $81 ; , (comma) FCB $AC FDB ALLOT-8 COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT FDB SEMIS * *=======>> 88 << C, * FCB $82 FCC 'C' FCB $AC FDB COMMA-4 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT FDB SEMIS * *=======>> 89 << - ( minus sign ) * FCB $81 ; - FCB $AD FDB CCOMM-5 SUB FDB DOCOL,MINUS,PLUS FDB SEMIS * *=======>> 90 << = ( equals sign ) * FCB $81 ; = FCB $BD FDB SUB-4 EQUAL FDB DOCOL,SUB,ZEQU FDB SEMIS * *=======>> 91 << < ( left arrow ) * FCB $81 ; < FCB $BC FDB EQUAL-4 LESS FDB *+2 PULA ; pop data PULB TSX ; copy stack pointer CMPA 0,X ; compare upper bytes INS BGT LESST ; BNE LESSF CMPB 1,X BHI LESST LESSF CLRB ; set flag false BRA LESSX LESST LDAB #1 ; set flag true LESSX CLRA INS JMP PUSHBA * *=======>> 92 << > ( right arrow ) * FCB $81 ; > FCB $BE FDB LESS-4 GREAT FDB DOCOL,SWAP,LESS FDB SEMIS * *=======>> 93 << ROT * FCB $83 FCC 'RO' FCB $D4 FDB GREAT-4 ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP FDB SEMIS * *=======>> 94 << SPACE * FCB $85 FCC 'SPAC' FCB $C5 FDB ROT-6 SPACE FDB DOCOL,BL,EMIT FDB SEMIS * *=======>> 95 << MIN * FCB $83 FCC 'MI' FCB $CE FDB SPACE-8 MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN FDB MIN2-* FDB SWAP MIN2 FDB DROP FDB SEMIS * *=======>> 96 << MAX * FCB $83 FCC 'MA' FCB $D8 FDB MIN-6 MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN FDB MAX2-* FDB SWAP MAX2 FDB DROP FDB SEMIS * *=======>> 97 << -DUP * FCB $84 FCC '-DU' FCB $D0 FDB MAX-6 DDUP FDB DOCOL,DUP,ZBRAN FDB DDUP2-* FDB DUP DDUP2 FDB SEMIS * *=======>> 98 << TRAVERSE * FCB $88 FCC 'TRAVERS' FCB $C5 FDB DDUP-7 TRAV FDB DOCOL,SWAP TRAV2 FDB OVER,PLUS,LIT FDB $7F FDB OVER,CAT,LESS,ZBRAN FDB TRAV2-* FDB SWAP,DROP FDB SEMIS * *=======>> 99 << LATEST * FCB $86 FCC 'LATES' FCB $D4 FDB TRAV-11 LATEST FDB DOCOL,CURENT,AT,AT FDB SEMIS * *=======>> 100 << LFA * FCB $83 FCC 'LF' FCB $C1 FDB LATEST-9 LFA FDB DOCOL,LIT FDB 4 FDB SUB FDB SEMIS * *=======>> 101 << CFA * FCB $83 FCC 'CF' FCB $C1 FDB LFA-6 CFA FDB DOCOL,TWO,SUB FDB SEMIS * *=======>> 102 << NFA * FCB $83 FCC 'NF' FCB $C1 FDB CFA-6 NFA FDB DOCOL,LIT FDB 5 FDB SUB,ONE,MINUS,TRAV FDB SEMIS * *=======>> 103 << PFA * FCB $83 FCC 'PF' FCB $C1 FDB NFA-6 PFA FDB DOCOL,ONE,TRAV,LIT FDB 5 FDB PLUS FDB SEMIS * *=======>> 104 << !CSP * FCB $84 FCC '!CS' FCB $D0 FDB PFA-6 SCSP FDB DOCOL,SPAT,CSP,STORE FDB SEMIS * *=======>> 105 << ?ERROR * FCB $86 FCC '?ERRO' FCB $D2 FDB SCSP-7 QERR FDB DOCOL,SWAP,ZBRAN FDB QERR2-* FDB ERROR,BRAN FDB QERR3-* QERR2 FDB DROP QERR3 FDB SEMIS * *=======>> 106 << ?COMP * FCB $85 FCC '?COM' FCB $D0 FDB QERR-9 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT FDB $11 FDB QERR FDB SEMIS * *=======>> 107 << ?EXEC * FCB $85 FCC '?EXE' FCB $C3 FDB QCOMP-8 QEXEC FDB DOCOL,STATE,AT,LIT FDB $12 FDB QERR FDB SEMIS * *=======>> 108 << ?PAIRS * FCB $86 FCC '?PAIR' FCB $D3 FDB QEXEC-8 QPAIRS FDB DOCOL,SUB,LIT FDB $13 FDB QERR FDB SEMIS * *=======>> 109 << ?CSP * FCB $84 FCC '?CS' FCB $D0 FDB QPAIRS-9 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT FDB $14 FDB QERR FDB SEMIS * *=======>> 110 << ?LOADING * FCB $88 FCC '?LOADIN' FCB $C7 FDB QCSP-7 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT FDB $16 FDB QERR FDB SEMIS * *=======>> 111 << COMPILE * FCB $87 FCC 'COMPIL' FCB $C5 FDB QLOAD-11 COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA FDB SEMIS * *=======>> 112 << [ * FCB $C1 ; [ immediate FCB $DB FDB COMPIL-10 LBRAK FDB DOCOL,ZERO,STATE,STORE FDB SEMIS * *=======>> 113 << ] * FCB $81 ; ] FCB $DD FDB LBRAK-4 RBRAK FDB DOCOL,LIT FDB $C0 FDB STATE,STORE FDB SEMIS * *=======>> 114 << SMUDGE * FCB $86 FCC 'SMUDG' FCB $C5 FDB RBRAK-4 SMUDGE FDB DOCOL,LATEST,LIT FDB $20 FDB TOGGLE FDB SEMIS * *=======>> 115 << HEX * FCB $83 FCC 'HE' FCB $D8 FDB SMUDGE-9 HEX FDB DOCOL FDB LIT FDB 16 FDB BASE,STORE FDB SEMIS * *=======>> 116 << DECIMAL * FCB $87 FCC 'DECIMA' FCB $CC FDB HEX-6 DEC FDB DOCOL FDB LIT FDB 10 FDB BASE,STORE FDB SEMIS * *=======>> 117 << (;CODE) * FCB $87 FCC '(;CODE' FCB $A9 FDB DEC-10 PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE FDB SEMIS * *=======>> 118 << ;CODE * FCB $C5 FCC ';COD' FCB $C5 FDB PSCODE-10 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK FDB SEMIS * * note : `QSTACK` will be replaced by `ASSEMBLER` later * *=======>> 119 << <BUILDS * FCB $87 FCC '<BUILD' FCB $D3 FDB SEMIC-8 BUILDS FDB DOCOL,ZERO,CON FDB SEMIS * *=======>> 120 << DOES> * FCB $85 FCC 'DOES' FCB $BE FDB BUILDS-10 DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE FDB PSCODE * DODOES LDD IP ; get instruction pointer LDX RP ; get return pointer DEX DEX STX RP ; save rp STD 2,X LDX W ; INX INX STX N LDX 0,X STX IP ; CLRA LDAB #2 ADDD N PSHB PSHA JMP NEXT2 * *=======>> 121 << COUNT * FCB $85 FCC 'COUN' FCB $D4 FDB DOES-8 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT FDB SEMIS * *=======>> 122 << TYPE * FCB $84 FCC 'TYP' FCB $C5 FDB COUNT-8 TYPE FDB DOCOL,DDUP,ZBRAN FDB TYPE3-* FDB OVER,PLUS,SWAP,XDO1 TYPE2 FDB I,CAT,EMIT,XLOOP FDB TYPE2-* FDB BRAN FDB TYPE4-* TYPE3 FDB DROP TYPE4 FDB SEMIS * *=======>> 123 << -TRAILING * FCB $89 FCC '-TRAILIN' FCB $C7 FDB TYPE-7 DTRAIL FDB DOCOL,DUP,ZERO,XDO1 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL FDB SUB,ZBRAN FDB DTRAL3-* FDB LEAVE,BRAN FDB DTRAL4-* DTRAL3 FDB ONE,SUB DTRAL4 FDB XLOOP FDB DTRAL2-* FDB SEMIS * *=======>> 124 << (.@@@) * FCB $84 FCC '(."' FCB $A9 FDB DTRAIL-12 PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP FDB FROMR,PLUS,TOR,TYPE FDB SEMIS * *=======>> 125 << .@@@ * FCB $C2 FCC '.' FCB $A2 FDB PDOTQ-7 DOTQ FDB DOCOL FDB LIT FDB $22 FDB STATE,AT,ZBRAN FDB DOTQ1-* FDB COMPIL,PDOTQ,WORD FDB HERE,CAT,ONEP,ALLOT,BRAN FDB DOTQ2-* DOTQ1 FDB WORD,HERE,COUNT,TYPE DOTQ2 FDB SEMIS * *=======>> 126 << ?STACK MACHINE DEPENDENT * FCB $86 FCC '?STAC' FCB $CB FDB DOTQ-5 QSTACK FDB DOCOL,LIT FDB $12 FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE FDB QERR * * prints 'empty stack' * QSTAC2 FDB SPAT * * here we compare with a value at least 128 * higher than dict. ptr. (DP) * FDB HERE,LIT FDB $80 FDB PLUS,LESS,ZBRAN FDB QSTAC3-* FDB TWO FDB QERR * * prints 'full stack' * QSTAC3 FDB SEMIS * *=======>> 128 << EXPECT * FCB $86 FCC 'EXPEC' FCB $D4 FDB QSTACK-9 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO1 EXPEC2 FDB KEY,DUP,LIT FDB $0E FDB PORIG,AT,EQUAL,ZBRAN FDB EXPEC3-* FDB DROP,LIT FDB 8 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS FDB TOR,SUB,BRAN FDB EXPEC6-* EXPEC3 FDB DUP,LIT FDB $D FDB EQUAL,ZBRAN FDB EXPEC4-* FDB LEAVE,DROP,BL,ZERO,BRAN FDB EXPEC5-* EXPEC4 FDB DUP EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE EXPEC6 FDB EMIT,XLOOP FDB EXPEC2-* FDB DROP FDB SEMIS * *=======>> 129 << QUERY * FCB $85 FCC 'QUER' FCB $D9 FDB EXPECT-9 QUERY FDB DOCOL FDB TIB,AT,COLUMS FDB AT,EXPECT,ZERO,IN,STORE FDB SEMIS * *=======>> 130 << ( null - as in 00 hex ) * FCB $C1 FCB $80 FDB QUERY-8 NULL FDB DOCOL,BLK,AT,ZBRAN FDB NULL2-* FDB ONE,BLK,PSTORE FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD FDB ZEQU * check for end of screen FDB ZBRAN FDB NULL1-* FDB QEXEC,FROMR,DROP NULL1 FDB BRAN FDB NULL3-* NULL2 FDB FROMR,DROP NULL3 FDB SEMIS * *=======>> 133 << FILL * FCB $84 FCC 'FIL' FCB $CC FDB NULL-4 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP FDB FROMR,ONE,SUB,CMOVE FDB SEMIS * *=======>> 134 << ERASE * FCB $85 FCC 'ERAS' FCB $C5 FDB FILL-7 ERASE FDB DOCOL,ZERO,FILL FDB SEMIS * *=======>> 135 << BLANKS * FCB $86 FCC 'BLANK' FCB $D3 FDB ERASE-8 BLANKS FDB DOCOL,BL,FILL FDB SEMIS * *=======>> 136 << HOLD * FCB $84 FCC 'HOL' FCB $C4 FDB BLANKS-9 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE FDB SEMIS * *=======>> 137 << PAD * FCB $83 FCC 'PA' FCB $C4 FDB HOLD-7 PAD FDB DOCOL,HERE,LIT FDB $44 FDB PLUS FDB SEMIS * *=======>> 138 << WORD * FCB $84 FCC 'WOR' FCB $C4 FDB PAD-6 WORD FDB DOCOL,BLK,AT,ZBRAN FDB WORD2-* FDB BLK,AT,BLOCK,BRAN FDB WORD3-* WORD2 FDB TIB,AT WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT FDB 34 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE FDB SEMIS * *=======>> 139 << (NUMBER) * FCB $88 FCC '(NUMBER' FCB $A9 FDB WORD-7 PNUMB FDB DOCOL PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN FDB PNUMB4-* FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN FDB PNUMB3-* FDB ONE,DPL,PSTORE PNUMB3 FDB FROMR,BRAN FDB PNUMB2-* PNUMB4 FDB FROMR FDB SEMIS * *=======>> 140 << NUMBER * FCB $86 FCC 'NUMBE' FCB $D2 FDB PNUMB-11 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT FCB 0 FCC '-' FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB FDB ZBRAN FDB NUMB2-* FDB DUP,CAT,LIT FCB 0 FCC '.' FDB SUB,ZERO,QERR,ZERO,BRAN FDB NUMB1-* NUMB2 FDB DROP,FROMR,ZBRAN FDB NUMB3-* FDB DMINUS NUMB3 FDB SEMIS * *=======>> 141 << -FIND * FCB $85 FCC '-FIN' FCB $C4 FDB NUMB-9 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT FDB PFIND,DUP,ZEQU,ZBRAN FDB DFIND2-* FDB DROP,HERE,LATEST,PFIND DFIND2 FDB SEMIS * *=======>> 142 << (ABORT) * FCB $87 FCC '(ABORT' FCB $A9 FDB DFIND-8 PABORT FDB DOCOL,ABORT FDB SEMIS * *=======>> 143 << ERROR * FCB $85 FCC 'ERRO' FCB $D2 FDB PABORT-10 ERROR FDB DOCOL,WARN,AT,ZLESS FDB ZBRAN * * WARNING is -1 to abort, 0 to print error number * and 1 to print error message from disc * FDB ERROR2-* FDB PABORT ERROR2 FDB HERE,COUNT,TYPE,PDOTQ FCB 4 FCC ' ? ' FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT FDB SEMIS * *=======>> 144 << ID. * FCB $83 FCC 'ID' FCB $AE FDB ERROR-8 IDDOT FDB DOCOL,PAD,LIT FDB 32 FDB LIT FDB $5F ; ( underline ) FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD FDB SWAP,CMOVE,PAD,COUNT,LIT FDB 31 FDB AND,TYPE,SPACE FDB SEMIS * *=======>> 145 << CREATE * FCB $86 FCC 'CREAT' FCB $C5 FDB IDDOT-6 CREATE FDB DOCOL,DFIND,ZBRAN FDB CREAT2-* FDB DROP,CR,PDOTQ FCB 8 FCC ' redef: ' FDB NFA,IDDOT,LIT FDB 4 FDB MESS,SPACE CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN FDB ONEP,ALLOT,DUP,LIT FDB $A0 FDB TOGGLE,HERE,ONE,SUB,LIT FDB $80 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE FDB HERE,TWOP,COMMA FDB SEMIS * *=======>> 146 << [COMPILE] * FCB $C9 ; immediate FCC '[COMPILE' FCB $DD FDB CREATE-9 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA FDB SEMIS * *=======>> 147 << LITERAL * FCB $C7 ; immediate FCC 'LITERA' FCB $CC FDB BCOMP-12 LITER FDB DOCOL,STATE,AT,ZBRAN FDB LITER2-* FDB COMPIL,LIT,COMMA LITER2 FDB SEMIS * *=======>> 148 << DLITERAL * FCB $C8 ; immediate FCC 'DLITERA' FCB $CC FDB LITER-10 DLITER FDB DOCOL,STATE,AT,ZBRAN FDB DLITE2-* FDB SWAP,LITER,LITER DLITE2 FDB SEMIS * *=======>> 149 << INTERPRET * FCB $89 FCC 'INTERPRE' FCB $D4 FDB DLITER-11 INTERP FDB DOCOL INTER2 FDB DFIND,ZBRAN FDB INTER5-* FDB STATE,AT,LESS FDB ZBRAN FDB INTER3-* FDB CFA,COMMA,BRAN FDB INTER4-* INTER3 FDB CFA,EXEC INTER4 FDB BRAN FDB INTER7-* INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN FDB INTER6-* FDB DLITER,BRAN FDB INTER7-* INTER6 FDB DROP,LITER INTER7 FDB QSTACK,BRAN FDB INTER2-* ; branch always * *=======>> 150 << IMMEDIATE * FCB $89 FCC 'IMMEDIAT' FCB $C5 FDB INTERP-12 IMMED FDB DOCOL,LATEST,LIT FDB $40 FDB TOGGLE FDB SEMIS * *=======>> 151 << VOCABULARY * FCB $8A FCC 'VOCABULAR' FCB $D9 FDB IMMED-12 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES DOVOC FDB TWOP,CONTXT,STORE FDB SEMIS * *=======>> 153 << DEFINITIONS * FCB $8B FCC 'DEFINITION' FCB $D3 FDB VOCAB-13 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE FDB SEMIS * *=======>> 154 << ( * FCB $C1 ; immediate ( FCB $A8 FDB DEFIN-14 PAREN FDB DOCOL,LIT FCB 0 FCC ')' FDB WORD FDB SEMIS * *=======>> 155 << QUIT * FCB $84 FCC 'QUI' FCB $D4 FDB PAREN-4 QUIT FDB DOCOL FDB ZERO,BLK,STORE,LBRAK * * Here is the outer interpreter * which gets a line of input, does it, prints " OK" * then repeats : * QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU FDB ZBRAN FDB QUIT3-* FDB PDOTQ FCB 3 FCC ' OK' QUIT3 FDB BRAN FDB QUIT2-* ; branch always * *=======>> 156 << ABORT * FCB $85 FCC 'ABOR' FCB $D4 FDB QUIT-7 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,CR,MTBUF FDB RESTR FDB FIRST,DUP,USE,STORE,PREV,STORE ; added 2/7/90 FDB PDOTQ FCB 15 FCC ' HCforth v2.0 ' FDB FORTH,DEFIN,CR FDB QUIT ; branch always * *=======>> 157 << COLD * * bootstrap code - move rom contents to ram * FCB $84 FCC 'COL' FCB $C4 FDB ABORT-8 COLD FDB *+2 CENT LDS #REND-1 ; top of destination LDX #ERAM ; top of stuff to move COLD2 DEX LDAA 0,X PSHA ; move TASK and FORTH to ram CPX #RAM BNE COLD2 * LDS #XFENCE-1 ; put stack at a safe place for now LDX COLINT STX XCOLUM ; columns LDX DELINT STX XDELAY ; delay LDX VOCINT STX XVOCL ; vocabulary link LDX DPINIT STX XDP ; dictionary pointer LDX FENCIN STX XFENCE ; fence * WENT LDS #XFENCE-1 ; top of destination LDX #FENCIN ; top of stuff to move WARM2 DEX LDAA 0,X ; get byte PSHA ; save byte CPX #SINIT ; done ? BNE WARM2 ; no * LDS SINIT ; load stack pointer LDX UPINIT ; STX UP ; init user ram pointer LDX #ABORT ; get cfa of abort STX IP ; and save as first instruction * * start the virtual machine running * JMP RPSTOR+2 ; * * here is the stuff that gets copied to ram * RAM FDB RAMTOP,RAMTOP,0,0 * *=======>> 152 << * FCB $C5 ; immediate FCC 'FORT' FCB $C8 FDB NOOP-7 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 FCC '(C) Forth Interest Group, 1979' * FCB $84 FCC 'TAS' FCB $CB FDB FORTH-8 RTASK FDB DOCOL,SEMIS ERAM EQU * * *=======>> 158 << S->D * FCB $84 ; sign extend word to double FCC 'S->' FCB $C4 FDB COLD-7 STOD FDB DOCOL,DUP,ZLESS,MINUS FDB SEMIS * *=======>> 159 << * * FCB $81 ; multiply two words FCB $AA FDB STOD-7 STAR FDB *+2 LDAA #16 ; bits/word counter PSHA CLRA CLRB TSX STAR2 ROR 3,X ; shift multiplier ROR 4,X DEC 0,X ; done ? BMI STAR4 ; yes BCC STAR3 ADDD 1,X STAR3 RORA RORB ; shift result BRA STAR2 STAR4 INS ; dump counter INS INS JMP NEXT ; * *=======>> 160 << /MOD * FCB $84 FCC '/MO' FCB $C4 FDB STAR-4 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH FDB SEMIS * *=======>> 161 << / * FCB $81 ; / FCB $AF FDB SLMOD-7 SLASH FDB DOCOL,SLMOD,SWAP,DROP FDB SEMIS * *=======>> 162 << MOD * FCB $83 FCC 'MO' FCB $C4 FDB SLASH-4 MOD FDB DOCOL,SLMOD,DROP FDB SEMIS * *=======>> 163 << */MOD * FCB $85 FCC '*/MO' FCB $C4 FDB MOD-6 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH FDB SEMIS * *=======>> 164 << */ * FCB $82 FCC '*' FCB $AF FDB SSMOD-8 SSLASH FDB DOCOL,SSMOD,SWAP,DROP FDB SEMIS * *=======>> 165 << M/MOD * FCB $85 FCC 'M/MO' FCB $C4 FDB SSLASH-5 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH FDB FROMR,SWAP,TOR,USLASH,FROMR FDB SEMIS * *=======>> 166 << ABS * FCB $83 FCC 'AB' FCB $D3 FDB MSMOD-8 ABS FDB DOCOL,DUP,ZLESS,ZBRAN FDB ABS2-* FDB MINUS ABS2 FDB SEMIS * *=======>> 167 << DABS * FCB $84 FCC 'DAB' FCB $D3 FDB ABS-6 DABS FDB DOCOL,DUP,ZLESS,ZBRAN FDB DABS2-* FDB DMINUS DABS2 FDB SEMIS * * disc primitives * *=======>> 168 << USE * FCB $83 FCC 'US' FCB $C5 FDB DABS-7 USE FDB DOCON FDB XUSE * *=======>> 169 << PREV * FCB $84 FCC 'PRE' FCB $D6 FDB USE-6 PREV FDB DOCON FDB XPREV * *=======>> 170 << +BUF * FCB $84 FCC '+BU' FCB $C6 FDB PREV-7 PBUF FDB DOCOL,LIT FDB 260 ; FDB PLUS,DUP,LIMIT FDB EQUAL,ZBRAN FDB PBUF2-* FDB DROP,FIRST PBUF2 FDB DUP,PREV,AT,SUB FDB SEMIS * *=======>> 171 << UPDATE * FCB $86 FCC 'UPDAT' FCB $C5 FDB PBUF-7 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE FDB SEMIS * *=======>> 172 << EMPTY-BUFFERS * FCB $8D FCC 'EMPTY-BUFFER' FCB $D3 FDB UPDATE-9 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE FDB SEMIS * *=======>> 175 << BUFFER * FCB $86 FCC 'BUFFE' FCB $D2 FDB MTBUF-16 BUFFER FDB DOCOL,USE,AT,DUP,TOR BUFFR2 FDB PBUF,ZBRAN FDB BUFFR2-* FDB USE,STORE,R,AT,ZLESS FDB ZBRAN FDB BUFFR3-* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP FDB SEMIS * *=======>> 176 << BLOCK * FCB $85 FCC 'BLOC' FCB $CB FDB BUFFER-9 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN FDB BLOCK5-* BLOCK3 FDB PBUF,ZEQU,ZBRAN FDB BLOCK4-* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN FDB BLOCK3-* FDB DUP,PREV,STORE BLOCK5 FDB FROMR,DROP,TWOP FDB SEMIS * *=======>> 177 << (LINE) * FCB $86 FCC '(LINE' FCB $A9 FDB BLOCK-8 PLINE FDB DOCOL,TOR,LIT FDB $40 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT FDB $40 FDB SEMIS * *=======>> 178 << .LINE * FCB $85 FCC '.LIN' FCB $C5 FDB PLINE-9 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE FDB SEMIS * *=======>> 179 << MESSAGE * FCB $87 FCC 'MESSAG' FCB $C5 FDB DLINE-8 MESS FDB DOCOL,WARN,AT,ZBRAN FDB MESS3-* FDB DDUP,ZBRAN FDB MESS3-* FDB LIT,4 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN FDB MESS4-* MESS3 FDB PDOTQ ; print message FCB 6 FCC 'err # ' ; error number FDB DOT ; print top of stack MESS4 FDB SEMIS * *=======>> 180 << LOAD ; input scr # * FCB $84 FCC 'LOA' FCB $C4 FDB MESS-10 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE FDB BSCR,STAR,BLK,STORE FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE FDB SEMIS * *=======>> 181 << --> * FCB $C3 FCC '--' FCB $BE FDB LOAD-7 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE FDB SEMIS * * * *=======>> 182 << code for EMIT * * *=======>> 183 << code for key * * *=======>> 184 << code for ?TERMINAL * * *=======>> 185 << code for CR * * *=======>> 189 << BLOCK-WRITE ; write block to disk * FCB $8B FCC 'BLOCK-WRIT' FCB $C5 FDB ARROW-6 BWRITE FDB *+2 * * * JMP NEXT * *=======>> 190 << BLOCK-READ ; read block from disk * FCB $8A FCC 'BLOCK-REA' FCB $C4 FDB BWRITE-14 BREAD FDB *+2 * * * JMP NEXT * *=======>> 191 << R/W * FCB $83 FCC 'R/' FCB $D7 FDB BREAD-13 RW FDB DOCOL FDB ZBRAN ; branch if zero FDB RW3-* FDB BREAD ; read FDB BRAN FDB RW4-* RW3 FDB BWRITE ; write RW4 FDB SEMIS * *=======>> 192 << @@ ( an apostrophe ) * FCB $C1 FCB $A7 FDB RW-6 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER FDB SEMIS * *=======>> 193 << FORGET * FCB $86 FCC 'FORGE' FCB $D4 FDB TICK-4 * * * FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT FDB $18 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT FDB $15 FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE FDB SEMIS * *=======>> 194 << BACK * FCB $84 FCC 'BAC' FCB $CB FDB FORGET-9 BACK FDB DOCOL,HERE,SUB,COMMA FDB SEMIS * *=======>> 195 << BEGIN * FCB $C5 FCC 'BEGI' FCB $CE FDB BACK-7 BEGIN FDB DOCOL,QCOMP,HERE,ONE FDB SEMIS * *=======>> 196 << ENDIF * FCB $C5 FCC 'ENDI' FCB $C6 FDB BEGIN-8 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE FDB OVER,SUB,SWAP,STORE FDB SEMIS * *=======>> 197 << THEN * FCB $C4 FCC 'THE' FCB $CE FDB ENDIF-8 THEN FDB DOCOL,ENDIF FDB SEMIS * *=======>> 198 << DO * FCB $C2 FCC 'D' FCB $CF FDB THEN-7 DO FDB DOCOL,COMPIL,XDO1,HERE,THREE FDB SEMIS * *=======>> 199 << LOOP * FCB $C4 FCC 'LOO' FCB $D0 FDB DO-5 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK FDB SEMIS * *=======>> 200 << +LOOP * FCB $C5 FCC '+LOO' FCB $D0 FDB LOOP-7 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK FDB SEMIS * *=======>> 201 << UNTIL * FCB $C5 FCC 'UNTI' ; ( same as end ) FCB $CC FDB PLOOP-8 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK FDB SEMIS * *=======>> 202 << END * FCB $C3 FCC 'EN' FCB $C4 FDB UNTIL-8 END FDB DOCOL,UNTIL FDB SEMIS * *=======>> 203 << AGAIN * FCB $C5 FCC 'AGAI' FCB $CE FDB END-6 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK FDB SEMIS * *=======>> 204 << REPEAT * FCB $C6 FCC 'REPEA' FCB $D4 FDB AGAIN-8 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR FDB TWO,SUB,ENDIF FDB SEMIS * *=======>> 205 << IF * FCB $C2 FCC 'I' FCB $C6 FDB REPEAT-9 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO FDB SEMIS * *=======>> 206 << ELSE * FCB $C4 FCC 'ELS' FCB $C5 FDB IF-5 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO FDB SEMIS * *=======>> 207 << WHILE * FCB $C5 FCC 'WHIL' FCB $C5 FDB ELSE-7 WHILE FDB DOCOL,IF,TWOP FDB SEMIS * *=======>> 208 << SPACES * FCB $86 FCC 'SPACE' FCB $D3 FDB WHILE-8 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN FDB SPACE3-* FDB ZERO,XDO1 SPACE2 FDB SPACE,XLOOP FDB SPACE2-* SPACE3 FDB SEMIS * *=======>> 209 << <# * FCB $82 FCC '<' FCB $A3 FDB SPACES-9 BDIGS FDB DOCOL,PAD,HLD,STORE FDB SEMIS * *=======>> 210 << #> * FCB $82 FCC '#' FCB $BE FDB BDIGS-5 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB FDB SEMIS * *=======>> 211 << SIGN * FCB $84 FCC 'SIG' FCB $CE FDB EDIGS-5 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN FDB SIGN2-* FDB LIT FCB 0 FCC '-' FDB HOLD SIGN2 FDB SEMIS * *=======>> 212 << # ( octothorpe ) * FCB $81 FCB $A3 FDB SIGN-7 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT FDB 9 FDB OVER,LESS,ZBRAN FDB DIG2-* FDB LIT FDB 7 FDB PLUS DIG2 FDB LIT FCB 0 FCC '0' ; ascii zero FDB PLUS,HOLD FDB SEMIS * *=======>> 213 << #S * FCB $82 FCC '#' FCB $D3 FDB DIG-4 DIGS FDB DOCOL DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN FDB DIGS2-* FDB SEMIS * *=======>> 214 << .R * FCB $82 FCC '.' FCB $D2 FDB DIGS-5 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR FDB SEMIS * *=======>> 215 << D.R * FCB $83 FCC 'D.' FCB $D2 FDB DOTR-5 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE FDB SEMIS * *=======>> 216 << D. * FCB $82 FCC 'D' FCB $AE FDB DDOTR-6 DDOT FDB DOCOL,ZERO,DDOTR,SPACE FDB SEMIS * *=======>> 217 << . ( period ) * FCB $81 FCB $AE FDB DDOT-5 DOT FDB DOCOL,STOD,DDOT FDB SEMIS * *=======>> 218 << ? ( question mark ) * FCB $81 FCB $BF FDB DOT-4 QUEST FDB DOCOL,AT,DOT FDB SEMIS * *=======>> 219 << LIST * FCB $84 FCC 'LIS' FCB $D4 FDB QUEST-4 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ FCB 6 FCC 'SCR # ' FDB DOT,LIT FDB $10 FDB ZERO,XDO1 LIST2 FDB CR,I,THREE FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP FDB LIST2-* FDB CR FDB SEMIS * *=======>> 220 << INDEX * FCB $85 FCC 'INDE' FCB $D8 FDB LIST-7 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO1 INDEX2 FDB CR,I,THREE FDB DOTR,SPACE,ZERO,I,DLINE FDB QTERM,ZBRAN FDB INDEX3-* FDB LEAVE INDEX3 FDB XLOOP FDB INDEX2-* FDB CR FDB SEMIS * *=======>> 221 << TRIAD * FCB $85 FCC 'TRIA' FCB $C4 FDB INDEX-8 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR FDB THREE,OVER,PLUS,SWAP,XDO1 TRIAD2 FDB CR,I FDB LIST,QTERM,ZBRAN FDB TRIAD3-* FDB LEAVE TRIAD3 FDB XLOOP FDB TRIAD2-* FDB CR,LIT FDB $0F FDB MESS,CR FDB SEMIS * *=======>> 222 << VLIST * FCB $85 FCC 'VLIS' FCB $D4 FDB TRIAD-8 VLIST FDB DOCOL,LIT FDB $80 FDB OUT,STORE,CONTXT,AT,AT VLIST1 FDB OUT,AT,COLUMS,AT,LIT FDB 32 FDB SUB,GREAT,ZBRAN FDB VLIST2-* FDB CR,ZERO,OUT,STORE VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT FDB DUP,ZEQU,QTERM,OR,ZBRAN FDB VLIST1-* FDB DROP FDB CR FDB SEMIS * *=======>> 223 << PAUSE ; one second pause * FCB $85 FCC 'PAUS' FCB $C5 FDB VLIST-8 PAUSE FDB *+2 LDX #1000 ; 1000 milliseconds PAUS1 LDAA #$C8 ; 1 msec @ 4.00 mhz PAUS2 DECA ; BNE PAUS2 ; DEX ; BNE PAUS1 ; JMP NEXT * *=======>> 224 << C/L ; characters/line * FCB $83 FCC 'C/' FCB $CC FDB PAUSE-8 CL FDB DOCON ; 64 characters per line FDB 64 * *=======>> 225 << DEPTH ; no operation * FCB $85 FCC 'DEPT' FCB $C8 FDB CL-6 DEPTH FDB DOCOL,SZERO,AT,SPAT FDB SUB,TWO,SLASH,ONE,SUB FDB SEMIS * *=======>> 226 << .S ; print out contents of stack * FCB $82 FCC '.' FCB $D3 FDB DEPTH-8 DOTS FDB DOCOL,DEPTH,ZBRAN ; if zero, print empty message FDB DOTS2-* FDB CR,SPAT,TWO,SUB FDB SZERO,AT,TWO,SUB FDB XDO1 DOTS1 FDB I,AT,DOT,LIT,$FFFE,XPLOOP FDB DOTS1-* FDB BRAN FDB DOTS3-* ; skip over message DOTS2 FDB PDOTQ FCB 14 FCC ' stack empty! ' DOTS3 FDB QUIT,SEMIS * *=======>> 227 << DUMP * FCB $84 FCC 'DUM' FCB $D0 FDB DOTS-5 DUMP FDB DOCOL,HEX,CR,CR,LIT,5,SPACES FDB LIT,16,ZERO,XDO1 DUMP1 FDB I,LIT,3,DOTR,XLOOP FDB DUMP1-* FDB TWO,SPACES,LIT,16,ZERO,XDO1 DUMP2 FDB I,ZERO,BDIGS,DIG,EDIGS,TYPE,XLOOP FDB DUMP2-* FDB CR,OVER,PLUS,SWAP,DUP,LIT,$F FDB AND,XOR,XDO1 DUMP3 FDB CR,I,ZERO,LIT,4,DDOTR,ONE FDB SPACES,I,LIT,16,PLUS,I FDB OVER,OVER,XDO1 DUMP4 FDB I,CAT,SPACE,ZERO,BDIGS,DIG,DIG FDB EDIGS,TYPE,XLOOP FDB DUMP4-* FDB TWO,SPACES,XDO1 DUMP5 FDB I,CAT,DUP,LIT,32,LESS,ZBRAN FDB DUMP6-* FDB DROP,LIT,46 DUMP6 FDB DUP,LIT,126,GREAT,ZBRAN FDB DUMP7-* FDB DROP,LIT,46 DUMP7 FDB EMIT,XLOOP FDB DUMP5-* FDB LIT,16,XPLOOP FDB DUMP3-* FDB CR,SEMIS * *=======>> 228 << ROOM ; number of bytes available * FCB $84 FCC 'ROO' FCB $CD FDB DUMP-7 ROOM FDB DOCOL,SZERO,AT,DP,AT FDB SUB,CR,DOT FDB PDOTQ FCB 16 FCC ' bytes available' FDB CR,SEMIS * *=======>> 229 << U. ; print unsigned double number * FCB $82 FCC 'U' FCB $AE FDB ROOM-7 UDOT FDB DOCOL,ZERO FDB DDOT,SEMIS * *=======>> 230 << NEXT-LINK ; address of NEXT * FCB $89 FCC 'NEXT-LIN' FCB $CB FDB UDOT-5 NEXTLNK FDB DOCON FDB NEXT * *=======>> 231 << W ; address of W * FCB $81 FCB $D7 FDB NEXTLNK-12 WREG FDB DOCON FDB W * *=======>> 232 << IP ; address of IP * FCB $82 FCC 'I' FCB $D0 FDB WREG-4 IPREG FDB DOCON FDB IP * *=======>> 235 << FLUSH ; flush updated buffers to disk * FCB $85 FCC 'FLUS' FCB $C8 FDB IPREG-5 FLUSH FDB DOCOL FDB LIT,8,ZERO,XDO1 FLUSH1 FDB LIT,$7FFF,BUFFER,DROP,XLOOP FDB FLUSH1-* FDB SEMIS * *=======>> << -ROT * FCB $84 FCC '-RO' FCB $D4 FDB FLUSH-8 DROT FDB DOCOL,SWAP,TOR FDB SWAP,FROMR,SEMIS * *=======>> << PICK * FCB $84 FCC 'PIC' FCB $CB FDB DROT-7 PICK FDB DOCOL,DUP,PLUS,SPAT FDB PLUS,AT,SEMIS * *=======>> << MYSELF * FCB $C6 FCC 'MYSEL' FCB $C6 FDB PICK-7 MSELF FDB DOCOL,LATEST,PFA,CFA,COMMA,SEMIS * *=======>> << ROLL * FCB $84 FCC 'ROL' FCB $CC FDB MSELF-9 ROLL FDB DOCOL,DUP,TWO,LESS,ZBRAN FDB ROL1-* FDB DROP,BRAN FDB ROL2-* ROL1 FDB SWAP,TOR,ONE,SUB FDB ROLL,FROMR,SWAP ROL2 FDB SEMIS * *=======>> << 2SWAP * FCB $85 FCC '2SWA' FCB $D0 FDB ROLL-7 TSWAP FDB DOCOL,ROT,TOR FDB ROT,FROMR,SEMIS * *=======>> << 2ROLL * FCB $84 FCC '2RO' FCB $D4 FDB TSWAP-8 TROT FDB TOR,TOR,TSWAP FDB FROMR,FROMR,TSWAP,SEMIS * *=======>> << 2DROP * FCB $85 FCC '2DRO' FCB $D0 FDB TROT-7 TDROP FDB DOCOL,DROP,DROP,SEMIS * *=======>> << 2DUP * FCB $84 FCC '2DU' FCB $D0 FDB TDROP-8 TDUP FDB DOCOL,OVER,OVER,SEMIS * *=======>> << 2OVER * FCB $85 FCC '2OVE' FCB $D2 FDB TDUP-7 TOVER FDB DOCOL,LIT,4,PICK FDB LIT,4,PICK,SEMIS * *=======>> << D- * FCB $82 FCC 'D' FCB $AD FDB TOVER-8 DSUB FDB DOCOL,DMINUS,DPLUS,SEMIS * *=======>> << D0= * FCB $83 FCC 'D0' FCB $BD FDB DSUB-5 DZEQ FDB DOCOL,OR,ZEQU,SEMIS * *=======>> << D0< * FCB $83 FCC 'D0' FCB $BC FDB DZEQ-6 DZLS FDB DOCOL,SWAP,DROP FDB ZLESS,SEMIS * *=======>> << D= * FCB $82 FCC 'D' FCB $BD FDB DZLS-6 DEQ FDB DOCOL,DSUB FDB DZEQ,SEMIS * *=======>> << D< * FCB $82 FCC 'D' FCB $BC FDB DEQ-5 DLS FDB DOCOL,DSUB,DZLS,SEMIS * *=======>> << D> * FCB $82 FCC 'D' FCB $BE FDB DLS-5 DGT FDB DOCOL,TSWAP,DLS,SEMIS * *=======>> << D+- * FCB $83 FCC 'D+' FCB $AD FDB DGT-5 DPLM FDB DOCOL,ZLESS,ZBRAN FDB DPLM1-* FDB MINUS DPLM1 FDB SEMIS * *=======>> << D* * FCB $82 FCC 'D' FCB $AA FDB DPLM-6 DSTAR FDB DOCOL,OVER,LIT,5,PICK FDB USTAR,LIT,6,ROLL FDB LIT,4,ROLL,STAR,PLUS,TSWAP FDB STAR,PLUS,SEMIS * *=======>> << UM* * FCB $83 FCC 'UM' FCB $AA FDB DSTAR-5 UMSTR FDB DOCOL,TOR,OVER,USTAR FDB ROT,FROMR,STAR,PLUS,SEMIS * *=======>> << UM/ * FCB $83 FCC 'UM' FCB $AF FDB UMSTR-6 UMSLSH FDB DOCOL,SWAP,OVER FDB SLMOD,TOR,SWAP FDB USLASH,SWAP,DROP FDB FROMR,SEMIS * *=======>> << RESTORE ; restore disk head to track 0 * FCB $87 FCC 'RESTOR' FCB $C5 FDB UMSLSH-6 RESTR FDB *+2 * * * JMP NEXT * *=======>> << SEEK ; disk head to track * FCB $84 FCC 'SEE' FCB $CB FDB RESTR-10 DSEEK FDB *+2 ; * * * JMP NEXT ; * *=======>> << TRACK ; disk head to track * FCB $85 FCC 'TRAC' FCB $CB FDB DSEEK-7 DTRACK FDB DOUSER ; FDB XTRACK-UORIG ; * *=======>> << SECTOR ; * FCB $86 FCC 'SECTO' FCB $D2 FDB DTRACK-8 DSECTOR FDB DOUSER ; FDB XSECTOR-UORIG ; * *=======>> << ; * FCB $87 FCC 'DSTATU' FCB $D3 FDB DSECTOR-9 DSTAT FDB DOUSER ; FDB XDSTAT-UORIG ; * *=======>> XX << NOOP ; no operation * FCB $84 FCC 'NOO' FCB $D0 FDB DSTAT-10 NOOP FDB NEXT ; a useful no-op * * end of forth * * * reset vectors for rom * ORG $FFD6 SCI FDB INIT SPI FDB INIT PAIE FDB INIT PAO FDB INIT TOF FDB INIT TOC5 FDB INIT TOC4 FDB INIT TOC3 FDB INIT TOC2 FDB INIT TOC1 FDB INIT TIC3 FDB INIT TIC2 FDB INIT TIC1 FDB INIT RTI FDB INIT IRQ FDB INIT XIRQ FDB INIT SWI FDB INIT ILLOP FDB INIT COP FDB INIT CLM FDB INIT RST FDB INIT * * * * END