3 * fig-FORTH FOR 6809, converted by unintelligent conversion from 6800 source.
7 * adjust ram locations -- OK?
8 * then add trace routines -- OK?
11 * ASSEMBLY SOURCE LISTING
15 * WITH COMPILER SECURITY
16 * AND VARIABLE LENGTH NAMES
18 * This public domain publication is provided
19 * through the courtesy of:
25 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
26 * Further distribution must include this notice.
28 NAM Copyright:FORTH Interest Group
31 * === FORTH-6800 06-06-79 21:OO
34 * This listing is in the PUBLIC DOMAIN and
35 * may be freely copied or published with the
36 * restriction that a credit line is printed
37 * with the material, crediting the
38 * authors and the FORTH INTEREST GROUP.
44 * === The Forth Interest Group
46 * === San Carlos, CA 94070
48 * === Unbounded Computing
49 * === 1134-K Aster Ave.
50 * === Sunnyvale, CA 94086
52 * This version was developed on an AMI EVK 300 PROTO
53 * system using an ACIA for the I/O. All terminal 1/0
54 * is done in three subroutines:
55 * PEMIT ( word # 182 )
58 * Note: PCR, also. (PRTCR)
60 * The FORTH words for disc related I/O follow the model
61 * of the FORTH Interest Group, but have not been
62 * tested using a real disc.
64 * Addresses in this implementation reflect the fact that,
65 * on the development system, it was convenient to
66 * write-protect memory at hex 1000, and leave the first
67 * 4K bytes write-enabled. As a consequence, code from
68 * location $1000 to lable ZZZZ could be put in ROM.
69 * Minor deviations from the model were made in the
70 * initialization and words ?STACK and FORGET
71 * in order to do this.
76 NBLK EQU 4 # of disc buffer blocks for virtual memory
77 * MEMEND EQU 132*NBLK+$3000 end of ram
78 MEMEND EQU 132*NBLK+$5000+132 end of ram with some breathing room (32K Coco)
79 * each block is 132 bytes in size,
80 * holding 128 characters
82 * MEMTOP EQU $3FFF absolute end of all ram
83 MEMTOP EQU $7FFF putative absolute end of all ram (32K Coco)
84 * No ACIA in Coco (how sad).
85 * ACIAC EQU $FBCE the ACIA control address and
86 * ACIAD EQU ACIAC+1 data address for PROTO
88 * MEMORY MAP for this 16K system (32K Coco):
89 * ( positioned so that systems with 4k byte write-
90 * protected segments can write protect FORTH )
92 * Read below and calculate it yourself:
93 * addr. contents pointer init by
94 * **** ******************************* ******* ******
96 * substitute for disc mass memory
99 * 4 buffer sectors of VIRTUAL MEMORY
101 * >>>>>> memory from here up must be RAM <<<<<<
104 * 6k of romable "FORTH" <== IP ABORT
106 * the VIRTUAL FORTH MACHINE
108 * 1004 (3004) <<< WARM START ENTRY >>>
109 * 1000 (3000) <<< COLD START ENTRY >>>
111 * >>>>>> memory from here down must be RAM <<<<<<
112 * FFE RETURN STACK base <== RP RINIT
116 * holds up to 132 characters
117 * and is scanned upward by IN
120 * F2F DATA STACK <== SP SP0,SINIT
121 * | grows downward from F2F
125 * I DICTIONARY grows upward
127 * 183 end of ram-dictionary. <== DP DPINIT
130 * 150 "FORTH" ( a word ) <=, <== CONTEXT
132 * 148 start of ram-dictionary.
134 * 100 user #l table of variables <= UP DPINIT
135 * F0 registers & pointers for the virtual machine
136 * scratch area used by various words
137 * E0 lowest address used by FORTH
143 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
145 * IP points to the current instruction ( pre-increment mode )
146 * RP points to second free byte (first free word) in return stack
147 * SP (hardware SP) points to first free byte in data stack
149 * when A AND B hold one 16 bit FORTH data word,
150 * A contains the high byte, B, the low byte.
159 PGBDP EQU PGBASE/$100
163 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
164 * SP@,SWAP,DOES>,COLD
167 * These locations are used by the TRACE routine :
169 TRLIM RMB 1 the count for tracing without user intervention
170 TRACEM RMB 1 non-zero = trace mode
171 BRKPT RMB 2 the breakpoint address at which
172 * the program will go into trace mode
173 VECT RMB 2 vector to machine code
174 * (only needed if the TRACE routine is resident)
177 * Registers used by the FORTH virtual machine:
181 W RMB 2 the instruction register points to 6800 code
182 IP RMB 2 the instruction pointer points to pointer to 6800 code
183 RP RMB 2 the return stack pointer
184 UP RMB 2 the pointer to base of current user's 'USER' table
185 * ( altered during multi-tasking )
196 * This system is shown with one user, but additional users
197 * may be added by allocating additional user tables:
198 * UORIG2 RMB 64 data table for user #2
201 * Some of this stuff gets initialized during
202 * COLD start and WARM start:
203 * [ names correspond to FORTH words of similar (no X) name ]
207 UORIG RMB 6 3 reserved variables
208 XSPZER RMB 2 initial top of data stack for this user
209 XRZERO RMB 2 initial top of return stack
210 XTIB RMB 2 start of terminal input buffer
211 XWIDTH RMB 2 name field width
212 XWARN RMB 2 warning message mode (0 = no disc)
213 XFENCE RMB 2 fence for FORGET
214 XDP RMB 2 dictionary pointer
215 XVOCL RMB 2 vocabulary linking
216 XBLK RMB 2 disc block being accessed
217 XIN RMB 2 scan pointer into the block
218 XOUT RMB 2 cursor position
219 XSCR RMB 2 disc screen being accessed ( O=terminal )
220 XOFSET RMB 2 disc sector offset for multi-disc
221 XCONT RMB 2 last word in primary search vocabulary
222 XCURR RMB 2 last word in extensible vocabulary
223 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
224 XBASE RMB 2 number base for I/O numeric conversion
225 XDPL RMB 2 decimal point place
227 XCSP RMB 2 current stack position, for compile checks
230 XDELAY RMB 2 carriage return delay count
231 XCOLUM RMB 2 carriage width
232 IOSTAT RMB 2 last acia status from write/read
243 * end of user table, start of common system variables
252 * These things, up through the lable 'REND', are overwritten
253 * at time of cold load and should have the same contents
260 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
263 FCC "(C) Forth Interest Group, 1979"
271 REND EQU * ( first empty location in dictionary )
274 * Check the addresses yourself:
275 * The FORTH program ( address $1000 to $27FF ) is written
276 * so that it can be in a ROM, or write-protected if desired
279 * ######>> screen 3 <<
281 ***************************
282 ** C O L D E N T R Y **
283 ***************************
286 ***************************
287 ** W A R M E N T R Y **
288 ***************************
290 JMP WENT warm-start code, keeps current dictionary intact
293 ******* startup parmeters **************************
295 RPTIB EQU $200 Give us more room to breath.
296 SBUMPR EQU $10 Bumper area for stacks.
298 FDB $6800,6809 cpu & revision
299 FDB 0 topmost word in FORTH vocabulary
300 BACKSP FDB $7F backspace character for editing
301 UPINIT FDB UORIG initial user area
302 * SINIT FDB ORIG-$D0 initial top of data stack
303 SINIT FDB ORIG-RPTIB-SBUMPR*2
304 * RINIT FDB ORIG-2 initial top of return stack
305 RINIT FDB ORIG-SBUMPR
306 * FDB ORIG-$D0 terminal input buffer
307 FDB ORIG-RPTIB-SBUMPR
308 FDB 31 initial name field width
309 FDB 0 initial warning mode (0 = no disc)
310 FENCIN FDB REND initial fence
311 DPINIT FDB REND cold start value for DP
313 COLINT FDB 132 initial terminal carriage width
314 DELINT FDB 4 initial carriage return delay
315 ****************************************************
319 * ######>> screen 13 <<
320 * Calculate the cycles yourself:
321 PULABX PULS A 24 cycles until 'NEXT'
323 STABX STA 0,X 16 cycles until 'NEXT'
326 GETX LDA 0,X 18 cycles until 'NEXT'
328 PUSHBA PSHS B 8 cycles until 'NEXT'
334 * "NEXT" takes 38 cycles if TRACE is removed,
336 * and 95 cycles if NOT tracing. (Way bogus numbers by now.)
338 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
341 LEAX 1,X pre-increment mode
344 NEXT2 LDX 0,X get W which points to CFA of word to be done
346 LDX 0,X get VECT which points to executable code
348 * The next instruction could be patched to JMP TRACE =
349 * if a TRACE routine is available: =
351 * Or add the TRACE routine in-line, since we are assembling it.
355 TFR S,X ; Mechanical! Mechanical! (So the funn 6800 stack didn't beach us.)
363 LEAX -1,X ; allocation link
364 LEAX -1,X ; last char
366 NAMTST LEAX -1,X ; length byte?
371 NAMTDN ANDB #31 ; It's the length byte whether it wants to be or not.
377 * show the virtual registers
378 * TOO MUCH OUTPUT! Have to trim this.
411 * JMP TRACE ( an alternate for the above )
419 JMP PEMIT ; rob return
437 JMP PEMIT ; rob return
440 INC FLAGON my version of trace
446 DEC FLAGON my version of trace
451 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
458 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
460 FDB 0 link of zero to terminate dictionary scan
470 * ######>> screen 14 <<
472 CLITER FDB *+2 (this is an invisible word, with no header)
482 FCC 'EXECUT' ; 'EXECUTE'
487 LDX 0,X get code field address (CFA)
492 * ######>> screen 15 <<
495 FCC 'BRANC' ; 'BRANCH'
498 BRAN FDB ZBYES Go steal code in ZBRANCH
502 FCC '0BRANC' ; '0BRANCH'
508 * ABA is only used here.
509 * Could immediately convert PULs to LDD ,S++ ;
510 * with no need for trailing BCS to look for overflow
511 * because we are only testing for non-zero, but,
512 * converting as if by unintelligent macro:
515 * End of unintelligent ABA conversion.
518 ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
526 ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
527 LEAX 1,X jump over branch delta
532 * ######>> screen 16 <<
535 FCC '(LOOP' ; '(LOOP)'
540 LDB #1 get set to increment counter by 1
541 BRA XPLOP2 go steal other guy's code!
545 FCC '(+LOOP' ; '(+LOOP)'
548 XPLOOP FDB *+2 Note: +LOOP has an un-signed loop counter
552 BPL XPLOF forward looping
558 BRA XPLONO fall through
562 ADDB 3,X add it to counter
564 STB 3,X store new counter value
573 XPLONO LEAX 1,X done, don't branch back
578 BRA ZBNO use ZBRAN to skip over unused delta
580 * ######>> screen 17 <<
586 XDO FDB *+2 This is the RUNTIME DO, not the COMPILING DO
613 * ######>> screen 18 <<
619 DIGIT FDB *+2 NOTE: legal input range is 0-9, A-Z
623 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
625 BMI DIGIT0 IF '9' OR LESS
627 BMI DIGIT2 if less than 'A'
629 BPL DIGIT2 if greater than 'Z'
630 SUBA #7 translate 'A' thru 'F'
632 BPL DIGIT2 if not less than the base
635 DIGIT1 STB 1,X store the flag
639 LEAS 1,S pop bottom number
641 STB 0,X make sure both bytes are 00
644 * ######>> screen 19 <<
646 * The word format in the dictionary is:
648 * char-count + $80 lowest address
653 * link high byte \___point to previous word
655 * CFA high byte \___pnt to 6800 code
664 FCC '(FIND' ; '(FIND)'
670 PD EQU N ptr to dict word being checked
673 PCT EQU N+6 ; PC in 6800 source
676 PFIND0 PULS A loop to get arguments
683 PFIND1 LDB 0,X get count dict count
689 LDA 0,X get count from arg
693 CMPA ,S+ compare lengths
703 TSTB is dict entry neg. ?
709 PFIND3 LDX 0,X get new link
710 BNE PFIND1 continue if link not=0
717 PFIND8 PSHS B ; sim CBA
721 PFIND9 LDB 0,X scan forward to end of this name
728 FOUND LDA PD compute CFA
747 * ######>> screen 20 <<
750 FCC 'ENCLOS' ; 'ENCLOSE'
754 * FC means offset (bytes) to First Character of next word
755 * EW " " to End of Word
756 * NC " " to Next Character to start next enclose at
759 PULS B now, get the low byte, for an 8-bit delimiter
763 * wait for a non-delimiter or a NUL
767 CMPA ,S+ CHECK FOR DELIM
772 * found first character. Push FC
773 ENCL3 LDA N found first char.
777 * wait for a delimiter or a NUL
781 CMPA ,S+ ckech for delim.
791 * advance and push NC
794 * found NUL before non-delimiter, therefore there is no word
795 ENCL6 LDB N found NUL
800 * found NUL following the word instead of SPACE
809 * ######>> screen 21 <<
810 * The next 4 words call system dependant I/O routines
811 * which are listed after word "-->" ( lable: "arrow" )
843 FCC '?TERMINA' ; '?TERMINAL'
849 JMP PUSHBA stack the flag
860 * ######>> screen 22 <<
863 FCC 'CMOV' ; 'CMOVE' : source, destination, count
866 CMOVE FDB *+2 takes ( 43+47*count cycles )
870 STA 0,X move parameters to scratch area
892 * ######>> screen 23 <<
904 * The following is a subroutine which
905 * multiplies top 2 words on stack,
906 * leaving 32-bit result: high order word in A,B
907 * low order word in 2nd word of stack.
909 USTARS LDA #16 bits/word counter
914 USTAR2 ROR 5,X shift multiplier
924 USTAR4 LEAS 1,S dump counter
927 * ######>> screen 24 <<
962 JMP SWAP+4 reverse quotient & remainder
964 * ######>> screen 25 <<
1004 * ######>> screen 26 <<
1024 * Potential problem area? No. ******
1025 TFR X,S watch it ! X and S are not equal -- on 6800.
1026 * But they are on 6809, and that's what we want here.
1034 LDX RINIT initialize from rom constant
1047 STA FLAGON my version of trace
1054 LDX 0,X get address we have just finished.
1055 JMP NEXT+2 increment the return address & do next word
1057 * ######>> screen 27 <<
1060 FCC 'LEAV' ; 'LEAVE'
1111 * ######>> screen 28 <<
1134 LDA #$80 check the sign bit
1143 * ######>> screen 29 <<
1179 FCC 'MINU' ; 'MINUS'
1193 FCC 'DMINU' ; 'DMINUS'
1210 * ######>> screen 30 <<
1262 * ######>> screen 31 <<
1273 PULS A get stack data
1275 ADDB 1,X add & store low byte
1277 ADCA 0,X add & store hi byte
1283 FCC 'TOGGL' ; 'TOGGLE'
1286 TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1289 * ######>> screen 32 <<
1342 * ######>> screen 33 <<
1347 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
1351 * Here is the IP pusher for allowing
1352 * nested words in the virtual machine:
1353 * ( ;S is the equivalent un-nester )
1355 DOCOL LDX RP make room in the stack
1362 STA FLAGON my version of trace
1367 STA 2,X Store address of the high level word
1368 STB 3,X that we are starting to execute
1369 LDX W Get first sub-word of that definition
1370 JMP NEXT+2 and execute it
1373 FCB $C1 ; imnediate code
1376 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
1379 * ######>> screen 34 <<
1382 FCC 'CONSTAN' ; 'CONSTANT'
1385 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
1388 LDB 3,X A & B now contain the constant
1393 FCC 'VARIABL' ; 'VARIABLE'
1396 VAR FDB DOCOL,CON,PSCODE
1400 ADCA #0 A,B now contain the address of the variable
1408 USER FDB DOCOL,CON,PSCODE
1409 DOUSER LDX W get offset into user's table
1412 ADDB UP+1 add to users base address
1414 JMP PUSHBA push address of user's variable
1416 * ######>> screen 35 <<
1450 BL FDB DOCON ascii blank
1455 FCC 'FIRS' ; 'FIRST'
1459 FDB MEMEND-528 (132 * NBLK)
1463 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
1471 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
1479 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
1484 * blocks/screen = 1024 / "B/BUF" = 8
1488 FCC '+ORIGI' ; '+ORIGIN'
1491 PORIG FDB DOCOL,LIT,ORIG,PLUS
1494 * ######>> screen 36 <<
1521 FCC 'WIDT' ; 'WIDTH'
1529 FCC 'WARNIN' ; 'WARNING'
1537 FCC 'FENC' ; 'FENCE'
1545 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
1548 DICPT FDB DOUSER ; DP in 6800 source
1553 FCC 'VOC-LIN' ; 'VOC-LINK'
1569 FCC 'I' ; 'IN' : scan pointer for input line buffer
1590 * ######>> screen 37 <<
1594 FCC 'OFFSE' ; 'OFFSET'
1602 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
1610 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
1618 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
1626 FCC 'BAS' ; 'BASE' : number base for all input & output
1672 * ======>> 82.5 <<== SPECIAL
1674 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
1680 * ######>> screen 38 <<
1686 ONEP FDB DOCOL,ONE,PLUS
1694 TWOP FDB DOCOL,TWO,PLUS
1702 HERE FDB DOCOL,DICPT,AT
1707 FCC 'ALLO' ; 'ALLOT'
1710 ALLOT FDB DOCOL,DICPT,PSTORE
1717 COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
1725 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
1732 SUB FDB DOCOL,MINUS,PLUS
1739 EQUAL FDB DOCOL,SUB,ZEQU
1767 GREAT FDB DOCOL,SWAP,LESS
1775 ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
1780 FCC 'SPAC' ; 'SPACE'
1783 SPACE FDB DOCOL,BL,EMIT
1791 MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
1802 MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
1813 DDUP FDB DOCOL,DUP,ZBRAN
1818 * ######>> screen 39 <<
1821 FCC 'TRAVERS' ; 'TRAVERSE'
1825 TRAV2 FDB OVER,PLUS,CLITER
1827 FDB OVER,CAT,LESS,ZBRAN
1834 FCC 'LATES' ; 'LATEST'
1837 LATEST FDB DOCOL,CURENT,AT,AT
1845 LFA FDB DOCOL,CLITER
1855 CFA FDB DOCOL,TWO,SUB
1863 NFA FDB DOCOL,CLITER
1865 FDB SUB,ONE,MINUS,TRAV
1873 PFA FDB DOCOL,ONE,TRAV,CLITER
1878 * ######>> screen 40 <<
1884 SCSP FDB DOCOL,SPAT,CSP,STORE
1889 FCC '?ERRO' ; '?ERROR'
1892 QERR FDB DOCOL,SWAP,ZBRAN
1901 FCC '?COM' ; '?COMP'
1904 QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER
1911 FCC '?EXE' ; '?EXEC'
1914 QEXEC FDB DOCOL,STATE,AT,CLITER
1921 FCC '?PAIR' ; '?PAIRS'
1924 QPAIRS FDB DOCOL,SUB,CLITER
1934 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER
1941 FCC '?LOADIN' ; '?LOADING'
1944 QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER
1949 * ######>> screen 41 <<
1952 FCC 'COMPIL' ; 'COMPILE'
1955 COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
1962 LBRAK FDB DOCOL,ZERO,STATE,STORE
1969 RBRAK FDB DOCOL,CLITER
1976 FCC 'SMUDG' ; 'SMUDGE'
1979 SMUDGE FDB DOCOL,LATEST,CLITER
1997 FCC 'DECIMA' ; 'DECIMAL'
2002 FCB 10 note: hex "A"
2006 * ######>> screen 42 <<
2009 FCC '(;CODE' ; '(;CODE)'
2012 PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
2017 FCC ';COD' ; ';CODE'
2020 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
2022 * note: "QSTACK" will be replaced by "ASSEMBLER" later
2024 * ######>> screen 43 <<
2027 FCC '<BUILD' ; '<BUILDS'
2030 BUILDS FDB DOCOL,ZERO,CON
2035 FCC 'DOES' ; 'DOES>'
2038 DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
2042 LDX RP make room on return stack
2046 STA 2,X push return address
2048 LDX W get addr of pointer to run-time code
2051 STX N stash it in scratch area
2054 CLRA get address of parameter
2058 PSHS B and push it on data stack
2062 * ######>> screen 44 <<
2065 FCC 'COUN' ; 'COUNT'
2068 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
2076 TYPE FDB DOCOL,DDUP,ZBRAN
2078 FDB OVER,PLUS,SWAP,XDO
2079 TYPE2 FDB I,CAT,EMIT,XLOOP
2088 FCC '-TRAILIN' ; '-TRAILING'
2091 DTRAIL FDB DOCOL,DUP,ZERO,XDO
2092 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
2107 PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
2108 FDB FROMR,PLUS,TOR,TYPE
2121 FDB COMPIL,PDOTQ,WORD
2122 FDB HERE,CAT,ONEP,ALLOT,BRAN
2124 DOTQ1 FDB WORD,HERE,COUNT,TYPE
2127 * ######>> screen 45 <<
2128 * ======>> 126 <<== MACHINE DEPENDENT
2130 FCC '?STAC' ; '?STACK'
2133 QSTACK FDB DOCOL,CLITER
2135 FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
2137 * prints 'empty stack'
2140 * Here, we compare with a value at least 128
2141 * higher than dict. ptr. (DP)
2148 * prints 'full stack'
2152 * ======>> 127 << this word's function
2153 * is done by ?STACK in this version
2158 *QFREE FDB DOCOL,SPAT,HERE,CLITER
2160 * FDB PLUS,LESS,TWO,QERR,SEMIS
2162 * ######>> screen 46 <<
2165 FCC 'EXPEC' ; 'EXPECT'
2168 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO
2169 EXPEC2 FDB KEY,DUP,CLITER
2171 FDB PORIG,AT,EQUAL,ZBRAN
2174 FCB 8 ( backspace character to emit )
2175 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
2178 EXPEC3 FDB DUP,CLITER
2179 FCB $D ( carriage return )
2182 FDB LEAVE,DROP,BL,ZERO,BRAN
2185 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
2186 EXPEC6 FDB EMIT,XLOOP
2193 FCC 'QUER' ; 'QUERY'
2196 QUERY FDB DOCOL,TIB,AT,COLUMS
2197 FDB AT,EXPECT,ZERO,IN,STORE
2201 FCB $C1 immediate < carriage return >
2204 NULL FDB DOCOL,BLK,AT,ZBRAN
2207 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
2209 * check for end of screen
2212 FDB QEXEC,FROMR,DROP
2215 NULL2 FDB FROMR,DROP
2218 * ######>> screen 47 <<
2224 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
2225 FDB FROMR,ONE,SUB,CMOVE
2230 FCC 'ERAS' ; 'ERASE'
2233 ERASE FDB DOCOL,ZERO,FILL
2238 FCC 'BLANK' ; 'BLANKS'
2241 BLANKS FDB DOCOL,BL,FILL
2249 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
2257 PAD FDB DOCOL,HERE,CLITER
2262 * ######>> screen 48 <<
2268 WORD FDB DOCOL,BLK,AT,ZBRAN
2270 FDB BLK,AT,BLOCK,BRAN
2273 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
2275 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
2276 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
2279 * ######>> screen 49 <<
2282 FCC '(NUMBER' ; '(NUMBER)'
2286 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
2288 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
2289 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
2292 PNUMB3 FDB FROMR,BRAN
2299 FCC 'NUMBE' ; 'NUMBER'
2302 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
2304 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
2305 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
2310 FDB SUB,ZERO,QERR,ZERO,BRAN
2312 NUMB2 FDB DROP,FROMR,ZBRAN
2319 FCC '-FIN' ; '-FIND'
2322 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
2323 FDB PFIND,DUP,ZEQU,ZBRAN
2325 FDB DROP,HERE,LATEST,PFIND
2328 * ######>> screen 50 <<
2331 FCC '(ABORT' ; '(ABORT)'
2334 PABORT FDB DOCOL,ABORT
2339 FCC 'ERRO' ; 'ERROR'
2342 ERROR FDB DOCOL,WARN,AT,ZLESS
2344 * note: WARNING is -1 to abort, 0 to print error #
2345 * and 1 to print error message from disc
2348 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
2351 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
2359 IDDOT FDB DOCOL,PAD,CLITER
2362 FCB $5F ( underline )
2363 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
2364 FDB SWAP,CMOVE,PAD,COUNT,CLITER
2369 * ######>> screen 51 <<
2372 FCC 'CREAT' ; 'CREATE'
2375 CREATE FDB DOCOL,DFIND,ZBRAN
2381 FDB NFA,IDDOT,CLITER
2384 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
2385 FDB ONEP,ALLOT,DUP,CLITER
2387 FDB TOGGLE,HERE,ONE,SUB,CLITER
2389 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
2393 * ######>> screen 52 <<
2396 FCC '[COMPILE' ; '[COMPILE]'
2399 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
2404 FCC 'LITERA' ; 'LITERAL'
2407 LITER FDB DOCOL,STATE,AT,ZBRAN
2409 FDB COMPIL,LIT,COMMA
2414 FCC 'DLITERA' ; 'DLITERAL'
2417 DLITER FDB DOCOL,STATE,AT,ZBRAN
2419 FDB SWAP,LITER,LITER
2422 * ######>> screen 53 <<
2425 FCC 'INTERPRE' ; 'INTERPRET'
2429 INTER2 FDB DFIND,ZBRAN
2439 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
2443 INTER6 FDB DROP,LITER
2444 INTER7 FDB QSTACK,BRAN
2446 * FDB SEMIS never executed
2449 * ######>> screen 54 <<
2452 FCC 'IMMEDIAT' ; 'IMMEDIATE'
2455 IMMED FDB DOCOL,LATEST,CLITER
2462 FCC 'VOCABULAR' ; 'VOCABULARY'
2465 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
2466 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
2467 DOVOC FDB TWOP,CONTXT,STORE
2472 * Note: FORTH does not go here in the rom-able dictionary,
2473 * since FORTH is a type of variable.
2478 FCC 'DEFINITION' ; 'DEFINITIONS'
2481 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
2488 PAREN FDB DOCOL,CLITER
2493 * ######>> screen 55 <<
2499 QUIT FDB DOCOL,ZERO,BLK,STORE
2502 * Here is the outer interpretter
2503 * which gets a line of input, does it, prints " OK"
2505 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
2513 * FDB SEMIS ( never executed )
2517 FCC 'ABOR' ; 'ABORT'
2520 ABORT FDB DOCOL,SPSTOR,DECIM,QSTACK,DRZERO,CR,PDOTQ
2522 FCC "Forth-68oo-68o9"
2525 * FDB SEMIS never executed
2528 * ######>> screen 56 <<
2529 * bootstrap code... moves rom contents to ram :
2536 * CENT LDS #REND-1 top of destination on 6800
2539 LDS #REND top of destination on 6809
2540 LDX #ERAM top of stuff to move
2543 PSHS A move TASK & FORTH to ram
2547 * LDS #XFENCE-1 put stack at a safe place for now -- 6800
2548 * But only matters if we're interrupted.
2549 LDS #XFENCE put stack at a safe place for now -- 6809
2562 * WENT LDS #XFENCE-1 top of destination -- 6800
2563 WENT LDS #XFENCE top of destination -- 6809
2564 LDX #FENCIN top of stuff to move
2571 * Don't get faked out.
2572 * This is just a safe place for the stack if we're interrupted.
2573 * ABORT sends us through RP! and then SP!
2574 * And SP! loads S through X, which is just fine for the 6809, too.
2577 STX UP init user ram pointer
2580 NOP Here is a place to jump to special user
2581 NOP initializations such as I/0 interrups
2584 * For systems with TRACE:
2586 STX TRLIM clear trace mode
2588 STX BRKPT clear breakpoint address
2591 STA FLAGON my version of trace
2594 JMP RPSTOR+2 start the virtual machine running !
2596 * Here is the stuff that gets copied to ram :
2599 RAM FDB $5000,$5000,0,0
2603 FCC 'FORT' ; 'FORTH'
2606 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
2608 FCC "(C) Forth Interest Group, 1979"
2613 RTASK FDB DOCOL,SEMIS
2614 ERAM FCC "David Lion"
2617 * ######>> screen 57 <<
2623 STOD FDB DOCOL,DUP,ZLESS,MINUS
2643 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
2650 SLASH FDB DOCOL,SLMOD,SWAP,DROP
2658 MOD FDB DOCOL,SLMOD,DROP
2663 FCC '*/MO' ; '*/MOD'
2666 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
2674 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
2679 FCC 'M/MO' ; 'M/MOD'
2682 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
2683 FDB FROMR,SWAP,TOR,USLASH,FROMR
2691 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
2701 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
2706 * ######>> screen 58 <<
2727 PBUF FDB DOCOL,CLITER
2729 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
2732 PBUF2 FDB DUP,PREV,AT,SUB
2737 FCC 'UPDAT' ; 'UPDATE'
2740 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
2745 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
2748 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
2756 DRZERO FDB DOCOL,ZERO,OFSET,STORE
2759 * ======>> 174 <<== system dependant word
2764 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
2767 * ######>> screen 59 <<
2770 FCC 'BUFFE' ; 'BUFFER'
2773 BUFFER FDB DOCOL,USE,AT,DUP,TOR
2774 BUFFR2 FDB PBUF,ZBRAN
2776 FDB USE,STORE,R,AT,ZLESS
2779 FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
2780 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
2783 * ######>> screen 60 <<
2786 FCC 'BLOC' ; 'BLOCK'
2789 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
2790 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
2792 BLOCK3 FDB PBUF,ZEQU,ZBRAN
2794 FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
2795 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
2798 BLOCK5 FDB FROMR,DROP,TWOP
2801 * ######>> screen 61 <<
2804 FCC '(LINE' ; '(LINE)'
2807 PLINE FDB DOCOL,TOR,CLITER
2809 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
2815 FCC '.LIN' ; '.LINE'
2818 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
2823 FCC 'MESSAG' ; 'MESSAGE'
2826 MESS FDB DOCOL,WARN,AT,ZBRAN
2832 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
2836 FCC 'err # ' ; 'err # '
2842 FCC 'LOA' ; 'LOAD' : input:scr #
2845 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
2846 FDB BSCR,STAR,BLK,STORE
2847 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
2855 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
2856 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
2861 * ######>> screen 63 <<
2862 * The next 4 subroutines are machine dependent, and are
2863 * called by words 13 through 16 in the dictionary.
2865 * ======>> 182 << code for EMIT
2866 * character to output in A
2874 * PEMIT STB N save B
2877 * BITB #2 check ready bit
2878 * BEQ PEMIT+4 if not ready for more data
2881 * STB IOSTAT-UORIG,X
2882 * LDB N recover B & X
2884 * RTS only A register may change
2885 * PEMIT JMP $E1D1 for MIKBUG
2886 * PEMIT FCB $3F,$11,$39 for PROTO
2887 * PEMIT JMP $D286 for Smoke Signal DOS
2889 * ======>> 183 << code for KEY
2890 * Returns input character in A
2896 LDB [$0088] (locate) save
2907 * BCC PKEY+4 no incoming data yet
2909 * ANDA #$7F strip parity bit
2911 * STB IOSTAT+1-UORIG,X
2915 * PKEY JMP $E1AC for MIKBUG
2916 * PKEY FCB $3F,$14,$39 for PROTO
2917 * PKEY JMP $D289 for Smoke Signal DOS
2919 * ######>> screen 64 <<
2920 * ======>> 184 << code for ?TERMINAL
2921 * Returns flag in A (non-zero if BREAK).
2932 PQTERN PULS Y,U,DP,PC
2934 * PQTER LDA ACIAC Test for 'break' condition
2935 * ANDA #$11 mask framing error bit and
2936 ** input buffer full
2938 * LDA ACIAD clear input buffer
2945 * ======>> 185 << code for CR
2947 PRTCR LDA #$D carriage return ; PCR in 6800 source
2948 BRA PEMIT Let PEMIT return
2955 * LDB XDELAY+1-UORIG,X
2957 * BMI PQTER2 return if minus
2958 * PSHS B save counter
2959 * BSR PEMIT print RUBOUTs to delay.....
2966 * ######>> screen 66 <<
2969 FCC '?DIS' ; '?DISC'
2975 * ######>> screen 67 <<
2978 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
2984 * ######>> screen 68 <<
2987 FCC 'BLOCK-REA' ; 'BLOCK-READ'
2993 *The next 3 words are written to create a substitute for disc
2994 * mass memory,located between $3210 & $3FFF in ram.
3001 FDB MEMEND a system dependent equate at front
3009 FDB MEMTOP ( $3FFF in this version )
3011 * ######>> screen 69 <<
3017 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
3021 FCC ' Range ?' ; ' Range ?'
3029 * ######>> screen 72 <<
3034 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
3039 FCC 'FORGE' ; 'FORGET'
3042 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
3044 FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER
3046 FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER
3048 FDB QERR,DUP,NFA,DICPT,STORE,LFA,AT,CONTXT,AT,STORE
3051 * ######>> screen 73 <<
3057 BACK FDB DOCOL,HERE,SUB,COMMA
3062 FCC 'BEGI' ; 'BEGIN'
3065 BEGIN FDB DOCOL,QCOMP,HERE,ONE
3070 FCC 'ENDI' ; 'ENDIF'
3073 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE
3074 FDB OVER,SUB,SWAP,STORE
3082 THEN FDB DOCOL,ENDIF
3090 DO FDB DOCOL,COMPIL,XDO,HERE,THREE
3098 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
3103 FCC '+LOO' ; '+LOOP'
3106 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
3111 FCC 'UNTI' ; 'UNTIL' : ( same as END )
3114 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
3117 * ######>> screen 74 <<
3128 FCC 'AGAI' ; 'AGAIN'
3131 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
3136 FCC 'REPEA' ; 'REPEAT'
3139 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
3148 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
3156 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
3157 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO
3162 FCC 'WHIL' ; 'WHILE'
3165 WHILE FDB DOCOL,IF,TWOP
3168 * ######>> screen 75 <<
3171 FCC 'SPACE' ; 'SPACES'
3174 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
3177 SPACE2 FDB SPACE,XLOOP
3186 BDIGS FDB DOCOL,PAD,HLD,STORE
3194 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
3202 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
3213 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER
3231 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
3235 * ######>> screen 76 <<
3241 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
3249 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
3250 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
3258 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
3265 DOT FDB DOCOL,STOD,DDOT
3272 QUEST FDB DOCOL,AT,DOT
3275 * ######>> screen 77 <<
3281 LIST FDB DOCOL,DECIM,CR,DUP,SCR,STORE,PDOTQ
3287 LIST2 FDB CR,I,THREE
3288 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
3295 FCC 'INDE' ; 'INDEX'
3298 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
3299 INDEX2 FDB CR,I,THREE
3300 FDB DOTR,SPACE,ZERO,I,DLINE
3310 FCC 'TRIA' ; 'TRIAD'
3313 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
3314 FDB THREE,OVER,PLUS,SWAP,XDO
3316 FDB LIST,QTERM,ZBRAN
3326 * ######>> screen 78 <<
3329 FCC 'VLIS' ; 'VLIST'
3332 VLIST FDB DOCOL,CLITER
3334 FDB OUT,STORE,CONTXT,AT,AT
3335 VLIST1 FDB OUT,AT,COLUMS,AT,CLITER
3339 FDB CR,ZERO,OUT,STORE
3340 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
3341 FDB DUP,ZEQU,QTERM,OR,ZBRAN
3351 NOOP FDB NEXT a useful no-op
3352 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program