OSDN -- オープンソース・ソフトウェアの開発とダウンロード
日本語の翻訳状況 translation status for ja
  • R/O
  • HTTP
  • SSH
  • HTTPS
Fork

fig-forth-6809: コミット

Source code for a fig Forth interpreter/compiler for the M6809.
M6809用の Forth 原語インタープリター・コンパイラーのソースコード。


コミットメタ情報

リビジョン287038534ac664af54f5e0aaade25b96e8f3f0de (tree)
日時2019-01-24 23:29:41
作者Joel Matthew Rees <joel.rees@gmai...>
コミッターJoel Matthew Rees

ログメッセージ

capable compiling counted loops

変更サマリ

差分

Binary files /dev/null and b/a.out differ
--- a/fig-forth-auto6809opt.asm
+++ b/fig-forth-auto6809opt.asm
@@ -102,7 +102,7 @@ NATWID EQU 2 ; bytes per natural integer/pointer
102102 *
103103 MEMT32 EQU $7FFF absolute end of all ram
104104 MEMT16 EQU $3FFF
105-MEMTOP EQU MEMT16 ; tentative guess
105+MEMTOP EQU MEMT32 ; tentative guess
106106 ACIAC EQU $FBCE the ACIA control address and
107107 ACIAD EQU ACIAC+1 data address for PROTO
108108 PAGE
@@ -117,10 +117,10 @@ ACIAD EQU ACIAC+1 data address for PROTO
117117 USERSZ EQU 256 ; (Addressable by DP)
118118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
119119 USER32 EQU 4
120-USERCT EQU USER16
120+USERCT EQU USER32
121121 IUP16 EQU MEMT16+1-USER16*USERSZ
122122 IUP32 EQU MEMT32+1-USER32*USERSZ
123-IUP EQU IUP16
123+IUP EQU IUP32
124124 IUPDP EQU IUP/256
125125 * user tables of variables
126126 * registers & pointers for the virtual machine
@@ -133,10 +133,10 @@ SCRSZ EQU 1024
133133 * 3300|7000 LO,MEMEND
134134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
135135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
136-RAMDSK EQU RAMD16
136+RAMDSK EQU RAMD32
137137 MEME16 EQU RAMD16
138138 MEME32 EQU RAMD32
139-MEMEND EQU MEME16
139+MEMEND EQU MEME32
140140 * 32FF|6FFF
141141 * 4 buffer sectors of VIRTUAL MEMORY
142142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
@@ -149,12 +149,12 @@ BUFSZ EQU (SECTSZ+SECTRL)*NBLK
149149 * 2EE0|6BE0 FIRST
150150 BUFB16 EQU MEME16-BUFSZ
151151 BUFB32 EQU MEME32-BUFSZ
152-BUFBAS EQU BUFB16
152+BUFBAS EQU BUFB32
153153 * "end" of "usable ram" -- in 16K
154154 * 2EE0|6BE0 <== RP RINIT
155155 IRP16 EQU BUFB16
156156 IRP32 EQU BUFB32
157-IRP EQU IRP16
157+IRP EQU IRP32
158158 * RETURN STACK
159159 * (64|112 levels nesting)
160160 RSTK16 EQU 128
@@ -162,7 +162,7 @@ RSTK32 EQU 224
162162 * (2E60|6B00)
163163 SFTB16 EQU IRP16-RSTK16
164164 SFTB32 EQU IRP32-RSTK32
165-SFTBND EQU SFTB16
165+SFTBND EQU SFTB32
166166 * INPUT LINE BUFFER
167167 * holds up to 256 characters
168168 * and is scanned upward by IN
@@ -171,11 +171,11 @@ TIBSZ EQU 256
171171 * 2D60|6A00
172172 ITIB16 EQU SFTB16-TIBSZ
173173 ITIB32 EQU SFTB32-TIBSZ
174-ITIB EQU ITIB16
174+ITIB EQU ITIB32
175175 * 2D60|6A00 <== IN TIB
176176 ISP16 EQU ITIB16
177177 ISP32 EQU ITIB32
178-ISP EQU ISP16
178+ISP EQU ISP32
179179 * 2D60|6A00 <== SP SP0,SINIT
180180 * DATA STACK
181181 * | grows downward from 2A60|6A00
@@ -204,6 +204,7 @@ ISP EQU ISP16
204204 * 1200 lowest address used by FORTH
205205 *
206206 CODEBG EQU $1200
207+* CODEBG EQU $3000
207208 *
208209 * >>>>>> memory from here down left alone <<<<<<
209210 * >>>>>> so we can safely call ROM routines <<<<<<
@@ -298,6 +299,7 @@ UP RMB 2 the pointer to base of current user's 'USER' table
298299 * ( altered during multi-tasking )
299300 *
300301 *UORIG RMB 6 3 reserved variables
302+ RMB 6 3 reserved variables
301303 XSPZER RMB 2 initial top of data stack for this user
302304 XRZERO RMB 2 initial top of return stack
303305 XTIB RMB 2 start of terminal input buffer
@@ -353,13 +355,14 @@ XPREV RMB 2
353355 ** C O L D E N T R Y **
354356 ***************************
355357 ORIG NOP
356- JMP CENT
358+* JMP CENT
359+ LBSR CENT
357360 ***************************
358361 ** W A R M E N T R Y **
359362 ***************************
360363 NOP
361- JMP WENT warm-start code, keeps current dictionary intact
362-
364+* JMP WENT warm-start code, keeps current dictionary intact
365+ LBSR WENT warm-start code, keeps current dictionary intact
363366 SETDP IUPDP
364367
365368 *
@@ -381,7 +384,7 @@ RINIT FDB IRP ; initial top of return stack
381384 FDB 0 initial warning mode (0 = no disc)
382385 FENCIN FDB REND initial fence
383386 DPINIT FDB REND cold start value for DICTPT
384-VOCINT FDB FORTH+8
387+VOCINT FDB FORTH+4*NATWID
385388 COLINT FDB 132 initial terminal carriage width
386389 DELINT FDB 4 initial carriage return delay
387390 ****************************************************
@@ -394,17 +397,17 @@ DELINT FDB 4 initial carriage return delay
394397 * They're too much trouble to use with native subroutine call anyway.
395398 * PULABX PULS A ; 24 cycles until 'NEXT'
396399 * PULS B ;
397-PULABX PULU A,B ; ?? cycles until 'NEXT'
400+* PULABX PULU A,B ; ?? cycles until 'NEXT'
398401 * STABX STA 0,X 16 cycles until 'NEXT'
399402 * STB 1,X
400-STABX STD 0,X ; ?? cycles until 'NEXT'
403+* STABX STD 0,X ; ?? cycles until 'NEXT'
401404 BRA NEXT
402405 * GETX LDA 0,X 18 cycles until 'NEXT'
403406 * LDB 1,X
404-GETX LDD 0,X ?? cycles until 'NEXT'
407+* GETX LDD 0,X ?? cycles until 'NEXT'
405408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
406409 * PSHS A ;
407-PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
410+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
408411
409412
410413 *
@@ -437,6 +440,8 @@ NEXT ; IP is Y, push before using, pull before you come back here.
437440 *
438441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
439442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
443+ BSR DBGNAM
444+ BSR DBGREG
440445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
441446 * NEXT3 STX W
442447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
@@ -447,14 +452,175 @@ NEXT3 ; W is X until you use X for something else. (TOS points back here.)
447452 * if a TRACE routine is available: =
448453 * =
449454 * JMP 0,X
455+
450456 JSR [,X] ; Saving the postinc cycles,
451457 * ; but X must be bumped NATWID to the parameters.
452- NOP
458+* NOP
453459 * JMP TRACE ( an alternate for the above )
460+ BSR DBGREG ( an alternate for the above )
454461 * In other words, with the call and the NOP,
455462 * there is room to patch the call with a JMP to your TRACE
456463 * routine, which you have to provide.
457464 BRA NEXT
465+*
466+DBGNAM PSHS CC,D,X,Y
467+ TST <TRACEM
468+ BEQ DBGNrt
469+ LEAX -3,X
470+DBGNlf LDB ,-X
471+ BPL DBGNlf
472+ LDY #$4C0
473+ LDB ,X+
474+DBGNlp LDB ,X+
475+ BMI DBGNll
476+ STB ,Y+
477+ BRA DBGNlp
478+DBGNll ANDB #$7F
479+ STB ,Y+
480+ LDB #$60
481+ BRA DBGNlt
482+DBGNlc STB ,Y+
483+DBGNlt CMPY #$4E0
484+ BLO DBGNlc
485+DBGNrt PULS CC,D,X,Y,PC
486+*
487+*
488+MKhxBh LSRB
489+ LSRB
490+ LSRB
491+ LSRB
492+MKhxBl ANDB #$0F
493+ ADDB #$30
494+ CMPB #$39
495+ BLS MKhxBx
496+ ADDB #$C7 ; ($40-$39)-$40
497+MKhxBx RTS
498+*
499+OUThxA EXG A,B
500+ BSR OUThxB
501+ EXG A,B
502+ RTS
503+*
504+OUThxD BSR OUThxA
505+OUThxB PSHS B
506+ BSR MKhxBh
507+ STB ,X+
508+ LDB ,S
509+ BSR MKhxBl
510+ STB ,X+
511+ PULS B,PC
512+*
513+DBGREG PSHS U,Y,X,DP,B,A,CC
514+ TST <TRACEM
515+ LBEQ DBGRrt
516+ LEAY DBGRLB,PCR
517+ LDX #$4E0
518+DBGRlp LDD ,Y++
519+ BEQ DBGRdn
520+ STD ,X++
521+ BRA DBGRlp
522+DBGRdn LDX #$500
523+ LDA 3,S ; DP
524+ LDB ,S ; CC
525+ BSR OUThxD
526+ LDB #$60
527+ STB ,X+
528+ LDD 3*NATWID+4,S ; PC:505
529+ BSR OUThxD
530+ LDB #$60
531+ STB ,X+
532+ TFR S,D ; 509
533+ ADDD #4*NATWID+4
534+ BSR OUThxD
535+ LDD 2*NATWID+4,S ; U:50E
536+ BSR OUThxD
537+ LDB #$60
538+ STB ,X+
539+ LDD 1*NATWID+4,S ; Y:513
540+ BSR OUThxD
541+ LDD 0*NATWID+4,S ; X at 517
542+ BSR OUThxD
543+ LDB #$60
544+ STB ,X+
545+ LDD 1,S ; D at 51C
546+ BSR OUThxD
547+ LDB #$60
548+ STB ,X+
549+ STB ,X+
550+ STB ,X+
551+ STB ,X+
552+ STB ,X+
553+ LDD [3*NATWID+4,S] ; PC
554+ BSR OUThxD
555+ LDB #$60
556+ STB ,X+
557+ LDD 4*NATWID+4,S ; S
558+ BSR OUThxD
559+ LDD [2*NATWID+4,S] ; U
560+ BSR OUThxD
561+ LDB #$60
562+ STB ,X+
563+ LDD [1*NATWID+4,S] ; Y
564+ LBSR OUThxD
565+ LDD [0*NATWID+4,S] ; X
566+ LBSR OUThxD
567+ LDB #$60
568+ STB ,X+
569+ STB ,X+
570+ STB ,X+
571+ STB ,X+
572+ STB ,X+
573+ LDB #0
574+ EXG B,DP
575+DBGRkl JSR [$A000]
576+ BEQ DBGRkl
577+ STD $43E
578+ EXG DP,B
579+ CMPA #$55 ; 'U'
580+ BEQ DBGRdU
581+ CMPA #$53 ; 'S'
582+ BEQ DBGRdS
583+ CMPA #$49 ; 'I'
584+ BNE DBGRrt
585+DBGRin LDD <XTIB
586+ ADDD <XIN
587+ TFR D,Y
588+ LBSR OUThxD
589+ LDB #$3a ; ':'
590+ STB ,X+
591+ LDA <XCOLUM
592+DBGRip LDB ,Y+
593+ STB ,X+
594+ BEQ DBGRrt
595+DBGRit DECA
596+ BNE DBGRip
597+ BRA DBGRrt
598+DBGRdS TFR S,Y
599+ BRA DBGRst
600+DBGRsp LDD ,Y++
601+ LBSR OUThxD
602+ LDB #$60
603+ STB ,X+
604+DBGRst CMPY <XRZERO
605+ BLO DBGRsp
606+ LDB #$3a ; ':'
607+ STB ,X+
608+ LDB #$55
609+ STB ,X+
610+DBGRdU LDY 2*NATWID+4,S
611+ BRA DBGRut
612+DBGRup LDD ,Y++
613+ LBSR OUThxD
614+ LDB #$60
615+ STB ,X+
616+DBGRut CMPY <XSPZER
617+ BLO DBGRup
618+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
619+DBGRLB FCC 'DPCC PC S U Y X A B '
620+ FDB 0,0
621+
622+
623+*
458624 * =
459625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
460626
@@ -482,7 +648,7 @@ NEXT3 ; W is X until you use X for something else. (TOS points back here.)
482648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
483649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
484650 FDB 0 ; link of zero to terminate dictionary scan
485-LIT FDB *+NATWID ; Note also that it is meaningless in native code.
651+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
486652 LDD ,Y++
487653 PSHU A,B
488654 RTS
@@ -528,6 +694,36 @@ LIT8 FDB *+NATWID (this was an invisible word, with no header)
528694 * LDB 1,X
529695 * JMP PUSHBA
530696 *
697+* ( n off --- n )
698+* off is offset in video buffer area.
699+ FCB $87
700+ FCC 'SHOWTO' ; 'SHOWTOS'
701+ FCB $D3 ; 'S'
702+ FDB LIT8-7
703+SHOTOS FDB *+NATWID
704+ LDX #$400
705+ LDD ,U++
706+ LEAX D,X
707+ LDD ,U
708+ LBSR OUThxD
709+ RTS
710+*
711+ FCB $85
712+ FCC 'TROF' ; 'TROFF'
713+ FCB $C6 ; 'F'|$80
714+ FDB SHOTOS-10
715+TROFF FDB *+NATWID
716+ CLR <TRACEM
717+ RTS
718+*
719+ FCB $84
720+ FCC 'TRO' ; 'TRON'
721+ FCB $CE ; 'N'|$80
722+ FDB TROFF-8
723+TRON FDB *+NATWID
724+ INC <TRACEM
725+ RTS
726+*
531727 * ======>> 3 <<
532728 * ( adr --- )
533729 * Jump to address on stack. Used by the "outer" interpreter to
@@ -536,7 +732,7 @@ LIT8 FDB *+NATWID (this was an invisible word, with no header)
536732 FCB $87
537733 FCC 'EXECUT' ; 'EXECUTE'
538734 FCB $C5
539- FDB LIT-7
735+ FDB TRON-7
540736 EXEC FDB *+NATWID
541737 PULU X ; Gotta have W anyway, just in case.
542738 JMP [,X] ; Tail return.
@@ -884,44 +1080,61 @@ PFIND FDB *+NATWID
8841080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
8851081 PD EQU 0 ; pointer to NFA of dict word being checked
8861082 *
1083+* INC <TRACEM
1084+* LBSR DBGREG
8871085 LDX PD,U ; Start in on the vocabulary (NFA).
8881086 PFNDLP LDY PA0,U ; Point to the name to check against.
8891087 LDB ,X+ ; get dict name length byte
8901088 TFR B,A ; Save it in case it matches.
8911089 ANDB #CTMASK
1090+* LBSR DBGREG
8921091 CMPB ,Y+ ; Compare lengths
1092+* LBSR DBGREG
8931093 BNE PFNDUN
8941094 PFNDBR LDB ,X+
8951095 TSTB ; ; Is high bit of character in dictionary entry set?
1096+* LBSR DBGREG
8961097 BPL PFNDCH
1098+* LBSR DBGREG
8971099 ANDB #$7F ; Clear high bit from dictionary.
8981100 CMPB ,Y+ ; Compare "last" characters.
1101+* LBSR DBGREG
8991102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
9001103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
1104+* LBSR DBGREG
9011105 BNE PFNDLP ; Continue if link not=0
9021106 *
9031107 * not found :
9041108 LEAU NATWID,U ; Return only false flag.
9051109 LDD #0
9061110 STD ,U
1111+* LBSR DBGREG
1112+* DEC <TRACEM
9071113 PULS Y,PC
9081114 *
9091115 PFNDCH CMPB ,Y+ ; Compare characters.
1116+* LBSR DBGREG
9101117 BEQ PFNDBR
9111118 PFNDUN
9121119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
1120+* LBSR DBGREG
9131121 BPL PFNDSC
1122+* LBSR DBGREG
9141123 BRA PFNDLN
9151124 *
9161125 * found :
9171126 *
9181127 FOUND LEAX 2*NATWID,X
1128+* LBSR DBGREG
9191129 STX NATWID,U
9201130 TFR A,B
9211131 CLRA
9221132 STD ,U
1133+* LBSR DBGREG
9231134 LDB #1
9241135 PSHU A,B
1136+* LBSR DBGREG
1137+* DEC <TRACEM
9251138 PULS Y,PC
9261139 *
9271140 * 6800 model:
@@ -1055,14 +1268,21 @@ ENCEND CLRA ; high byte -- buffer < 255 wide!
10551268 * Found NUL before non-delimiter, therefore there is no word
10561269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
10571270 STD ,U ; offset to NUL.
1058- ADDD #1 ; For some reason, point after NUL.
1271+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
10591272 PSHU A,B ;
10601273 SUBD #1 ; Next is not passed NUL.
10611274 PSHU A,B ; Stealing code will save only one byte.
10621275 RTS
10631276 * Found NUL following the word instead of delimiter.
1064-ENC0TR PSHU A,B ; Save offset to first after symbol (NUL)
1277+ENC0TR
1278+* INC <TRACEM
1279+* LBSR DBGREG
1280+ CLRA
1281+ PSHU A,B ; Save offset to first after symbol (NUL)
1282+* LBSR DBGREG
10651283 PSHU A,B ; and count scanned.
1284+* LBSR DBGREG
1285+* DEC <TRACEM
10661286 RTS
10671287 * NOTE :
10681288 * FC means offset (bytes) to First Character of next word
@@ -1136,7 +1356,8 @@ ENC0TR PSHU A,B ; Save offset to first after symbol (NUL)
11361356 FCB $D4
11371357 FDB ENCLOS-10
11381358 EMIT FDB *+NATWID
1139- LBSR PEMIT ; PEMIT handles the stack.
1359+ PULU D
1360+ LBSR PEMIT ; PEMIT expects the character in D.
11401361 INC <XOUT+1
11411362 BNE EMITDN
11421363 INC <XOUT
@@ -1161,7 +1382,8 @@ EMITDN RTS
11611382 FCB $D9
11621383 FDB EMIT-7
11631384 KEY FDB *+NATWID
1164- LBSR PKEY ; PKEY handles the stack.
1385+ LBSR PKEY ; PKEY leaves the key/break code in D.
1386+ PSHU D
11651387 RTS
11661388 * JSR PKEY
11671389 * PSHS A ;
@@ -1180,7 +1402,8 @@ KEY FDB *+NATWID
11801402 FCB $CC
11811403 FDB KEY-6
11821404 QTERM FDB *+NATWID
1183- LBSR PQTER ; PQTER handles the stack.
1405+ LBSR PQTER ; PQTER leaves the flag/key in D.
1406+ PSHU D
11841407 RTS
11851408 * JSR PQTER
11861409 * CLRB ;
@@ -1194,8 +1417,7 @@ QTERM FDB *+NATWID
11941417 FCB $D2
11951418 FDB QTERM-12
11961419 CR FDB *+NATWID
1197- LBSR PCR ; PCR handles the stack.
1198- RTS
1420+ LBRA PCR ; Nothing really to do here.
11991421 * JSR PCR
12001422 * JMP NEXT
12011423 *
@@ -1210,20 +1432,44 @@ CR FDB *+NATWID
12101432 FCB $C5
12111433 FDB CR-5
12121434 CMOVE FDB *+NATWID
1213-* One way: ; takes ( 37+17*count+9*(count/256) cycles )
1214- PSHS Y ; #2~7 ; Gotta have our pointers.
1215- PULU D,X,Y ; #2~11
1216- PSHS A ; #2~6 ; Gotta have our pointers.
1217- BRA CMOVLE ; #2~3
1435+ PSHS Y ;
1436+* INC <TRACEM
1437+* LBSR DBGREG
1438+ LDX 1*NATWID,U
1439+ LDY 2*NATWID,U
1440+ BRA CMOVLE ;
12181441 CMOVLP
1219- LDA ,Y+ ; #2~6
1220- STA ,X+ ; #2~6
1442+* LBSR DBGREG
1443+ LDA ,Y+
1444+ STA ,X+
1445+* LBSR DBGREG
12211446 CMOVLE
1222- SUBB #1 ; #2~2
1223- BCC CMOVLP ; #2~3
1224- DEC ,S ; #2=6
1225- BPL CMOVLP ; #2~3
1226- PULS A,Y,PC ; #2~10
1447+ LDD ,U
1448+ SUBD #1
1449+ STD ,U
1450+ BCC CMOVLP
1451+ LEAU 3*NATWID,U
1452+* DEC <TRACEM
1453+ PULS Y,PC
1454+* One way: ; takes ( 37+17*count+9*(count/256) cycles )
1455+* PSHS Y ; #2~7 ; Gotta have our pointers.
1456+* INC <TRACEM
1457+* LBSR DBGREG
1458+* PULU D,X,Y ; #2~11
1459+* PSHS A ; #2~6 ; Gotta have our pointers.
1460+* BRA CMOVLE ; #2~3
1461+* CMOVLP
1462+* LBSR DBGREG
1463+* LDA ,Y+ ; #2~6
1464+* STA ,X+ ; #2~6
1465+* LBSR DBGREG
1466+* CMOVLE
1467+* SUBB #1 ; #2~2
1468+* BCC CMOVLP ; #2~3
1469+* DEC ,S ; #2=6
1470+* BPL CMOVLP ; #2~3
1471+* DEC <TRACEM
1472+* PULS A,Y,PC ; #2~10
12271473 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
12281474 * LDD #0 ; #3~3
12291475 * SUBD ,U++ ; #2~9 ; invert the count
@@ -1336,7 +1582,7 @@ USTAR3 STD 1,U
13361582 BCC USTAR4
13371583 INC ,U
13381584 USTAR4 STD 1,U
1339- PULS D,X
1585+ PULU D,X
13401586 STD ,U
13411587 STX NATWID,U
13421588 RTS
@@ -2776,7 +3022,7 @@ MIN FDB *+NATWID
27763022 STD ,U
27773023 MINX RTS
27783024 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
2779-* FDB MIN2-*
3025+* FDB MIN2-*-NATWID
27803026 * FDB SWAP
27813027 * MIN2 FDB DROP
27823028 * FDB SEMIS
@@ -2796,7 +3042,7 @@ MAX FDB *+NATWID
27963042 STD ,U
27973043 MAXX RTS
27983044 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
2799-* FDB MAX2-*
3045+* FDB MAX2-*-NATWID
28003046 * FDB SWAP
28013047 * MAX2 FDB DROP
28023048 * FDB SEMIS
@@ -2815,7 +3061,7 @@ DDUP FDB *+NATWID
28153061 PSHU D
28163062 DDUPX RTS
28173063 * DDUP FDB DOCOL,DUP,ZBRAN
2818-* FDB DDUP2-*
3064+* FDB DDUP2-*-NATWID
28193065 * FDB DUP
28203066 * DDUP2 FDB SEMIS
28213067 *
@@ -2871,7 +3117,7 @@ TRAVDN STX ,U
28713117 * TRAV2 FDB OVER,PLUS,LIT8
28723118 * FCB $7F
28733119 * FDB OVER,CAT,LESS,ZBRAN
2874-* FDB TRAV2-*
3120+* FDB TRAV2-*-NATWID
28753121 * FDB SWAP,DROP
28763122 * FDB SEMIS
28773123 *
@@ -2994,9 +3240,9 @@ SCSP FDB DOCOL,SPAT,CSP,STORE
29943240 * RTS
29953241 ** this doesn't work anyway: QERROR LBR ERROR
29963242 QERR FDB DOCOL,SWAP,ZBRAN
2997- FDB QERR2-*
3243+ FDB QERR2-*-NATWID
29983244 FDB ERROR,BRAN
2999- FDB QERR3-*
3245+ FDB QERR3-*-NATWID
30003246 QERR2 FDB DROP
30013247 QERR3 FDB SEMIS
30023248 *
@@ -3084,7 +3330,8 @@ QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
30843330 FCB $C5
30853331 FDB QLOAD-11
30863332 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
3087-COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3333+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3334+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
30883335 FDB SEMIS
30893336 *
30903337 * ======>> 112 <<
@@ -3335,12 +3582,12 @@ COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
33353582 FCB $C5
33363583 FDB COUNT-8
33373584 TYPE FDB DOCOL,DDUP,ZBRAN
3338- FDB TYPE3-*
3585+ FDB TYPE3-*-NATWID
33393586 FDB OVER,PLUS,SWAP,XDO
33403587 TYPE2 FDB I,CAT,EMIT,XLOOP
3341- FDB TYPE2-*
3588+ FDB TYPE2-*-NATWID
33423589 FDB BRAN
3343- FDB TYPE4-*
3590+ FDB TYPE4-*-NATWID
33443591 TYPE3 FDB DROP
33453592 TYPE4 FDB SEMIS
33463593 *
@@ -3354,12 +3601,12 @@ TYPE4 FDB SEMIS
33543601 DTRAIL FDB DOCOL,DUP,ZERO,XDO
33553602 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
33563603 FDB SUB,ZBRAN
3357- FDB DTRAL3-*
3604+ FDB DTRAL3-*-NATWID
33583605 FDB LEAVE,BRAN
3359- FDB DTRAL4-*
3606+ FDB DTRAL4-*-NATWID
33603607 DTRAL3 FDB ONE,SUB
33613608 DTRAL4 FDB XLOOP
3362- FDB DTRAL2-*
3609+ FDB DTRAL2-*-NATWID
33633610 FDB SEMIS
33643611 *
33653612 * ======>> 124 <<
@@ -3370,7 +3617,8 @@ DTRAL4 FDB XLOOP
33703617 FCB $A9
33713618 FDB DTRAIL-12
33723619 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
3373-PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
3620+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
3621+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
33743622 FDB FROMR,PLUS,TOR,TYPE
33753623 FDB SEMIS
33763624 *
@@ -3388,10 +3636,10 @@ DOTQ FDB DOCOL
33883636 FDB LIT8
33893637 FCB $22 ascii quote
33903638 FDB STATE,AT,ZBRAN
3391- FDB DOTQ1-*
3639+ FDB DOTQ1-*-NATWID
33923640 FDB COMPIL,PDOTQ,WORD
33933641 FDB HERE,CAT,ONEP,ALLOT,BRAN
3394- FDB DOTQ2-*
3642+ FDB DOTQ2-*-NATWID
33953643 DOTQ1 FDB WORD,HERE,COUNT,TYPE
33963644 DOTQ2 FDB SEMIS
33973645 *
@@ -3425,7 +3673,7 @@ QSTAC2 FDB SPAT
34253673 FDB HERE,LIT8
34263674 FCB $80 ; This is a rough check anyway, leave it as is.
34273675 FDB PLUS,LESS,ZBRAN
3428- FDB QSTAC3-*
3676+ FDB QSTAC3-*-NATWID
34293677 FDB TWO ; NOT the NATWID constant!
34303678 FDB QERR
34313679 * prints 'full stack'
@@ -3455,25 +3703,28 @@ QSTAC3 FDB SEMIS
34553703 FCB $D4
34563704 FDB QSTACK-9
34573705 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
3458-EXPEC2 FDB KEY,DUP,LIT8
3706+* EXPEC2 FDB KEY,DUP,LIT8
3707+EXPEC2 FDB KEY
3708+ FDB LIT,$1C,SHOTOS ; DBG
3709+ FDB DUP,LIT8
34593710 FCB BACKSP-ORIG
34603711 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
3461- FDB EXPEC3-*
3712+ FDB EXPEC3-*-NATWID
34623713 FDB DROP,LIT8
34633714 FCB 8 ( backspace character to emit )
3464- FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back up TWO characters
3715+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
34653716 FDB TOR,SUB,BRAN
3466- FDB EXPEC6-*
3717+ FDB EXPEC6-*-NATWID
34673718 EXPEC3 FDB DUP,LIT8
34683719 FCB $D ( carriage return )
34693720 FDB EQUAL,ZBRAN
3470- FDB EXPEC4-*
3721+ FDB EXPEC4-*-NATWID
34713722 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
3472- FDB EXPEC5-*
3723+ FDB EXPEC5-*-NATWID
34733724 EXPEC4 FDB DUP
34743725 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
34753726 EXPEC6 FDB EMIT,XLOOP
3476- FDB EXPEC2-*
3727+ FDB EXPEC2-*-NATWID
34773728 FDB DROP
34783729 FDB SEMIS
34793730 *
@@ -3497,16 +3748,16 @@ QUERY FDB DOCOL,TIB,AT,COLUMS
34973748 FCB $80
34983749 FDB QUERY-8
34993750 NULL FDB DOCOL,BLK,AT,ZBRAN
3500- FDB NULL2-*
3751+ FDB NULL2-*-NATWID
35013752 FDB ONE,BLK,PSTORE
35023753 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
35033754 FDB ZEQU
35043755 * check for end of screen
35053756 FDB ZBRAN
3506- FDB NULL1-*
3757+ FDB NULL1-*-NATWID
35073758 FDB QEXEC,FROMR,DROP
35083759 NULL1 FDB BRAN
3509- FDB NULL3-*
3760+ FDB NULL3-*-NATWID
35103761 NULL2 FDB FROMR,DROP
35113762 NULL3 FDB SEMIS
35123763 *
@@ -3579,9 +3830,9 @@ PAD FDB DOCOL,HERE,LIT8
35793830 FCB $C4
35803831 FDB PAD-6
35813832 WORD FDB DOCOL,BLK,AT,ZBRAN
3582- FDB WORD2-*
3833+ FDB WORD2-*-NATWID
35833834 FDB BLK,AT,BLOCK,BRAN
3584- FDB WORD3-*
3835+ FDB WORD3-*-NATWID
35853836 WORD2 FDB TIB,AT
35863837 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
35873838 FCB 34
@@ -3602,13 +3853,13 @@ WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
36023853 FDB WORD-7
36033854 PNUMB FDB DOCOL
36043855 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3605- FDB PNUMB4-*
3856+ FDB PNUMB4-*-NATWID
36063857 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
36073858 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3608- FDB PNUMB3-*
3859+ FDB PNUMB3-*-NATWID
36093860 FDB ONE,DPL,PSTORE
36103861 PNUMB3 FDB FROMR,BRAN
3611- FDB PNUMB2-*
3862+ FDB PNUMB2-*-NATWID
36123863 PNUMB4 FDB FROMR
36133864 FDB SEMIS
36143865 *
@@ -3631,13 +3882,13 @@ NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
36313882 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
36323883 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
36333884 FDB ZBRAN
3634- FDB NUMB2-*
3885+ FDB NUMB2-*-NATWID
36353886 FDB DUP,CAT,LIT8
36363887 FCC "."
36373888 FDB SUB,ZERO,QERR,ZERO,BRAN
3638- FDB NUMB1-*
3889+ FDB NUMB1-*-NATWID
36393890 NUMB2 FDB DROP,FROMR,ZBRAN
3640- FDB NUMB3-*
3891+ FDB NUMB3-*-NATWID
36413892 FDB DMINUS
36423893 NUMB3 FDB SEMIS
36433894 *
@@ -3654,7 +3905,7 @@ NUMB3 FDB SEMIS
36543905 FDB NUMB-9
36553906 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
36563907 FDB PFIND,DUP,ZEQU,ZBRAN
3657- FDB DFIND2-*
3908+ FDB DFIND2-*-NATWID
36583909 FDB DROP,HERE,LATEST,PFIND
36593910 DFIND2 FDB SEMIS
36603911 *
@@ -3681,11 +3932,11 @@ PABORT FDB DOCOL,ABORT
36813932 * First, we need to get this transliteration running.
36823933 ERROR FDB DOCOL,WARN,AT,ZLESS
36833934 FDB ZBRAN
3935+ FDB ERROR2-*-NATWID
36843936 * note: WARNING is
36853937 * -1 to abort,
36863938 * 0 to print error #
36873939 * and 1 to print error message from disc
3688- FDB ERROR2-*
36893940 FDB PABORT
36903941 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
36913942 FCB 4,7 ( bell )
@@ -3694,18 +3945,51 @@ ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
36943945 FDB SEMIS
36953946 *
36963947 * ======>> 144 <<
3948+* ( n adr --- )
3949+* Mask byte at adr with n.
3950+* Not in FIG, don't need it for 8 bit characters after all.
3951+* FCB $85
3952+* FCC 'CMAS' ; 'CMASK'
3953+* FCB $CB ; 'K'
3954+* FDB ERROR-8
3955+* CMASK FDB *+NATWID
3956+* LDX ,U++ ; adr
3957+* LDD ,U++ ; mask
3958+* ANDB ,X
3959+* STB ,X
3960+* RTS
3961+*
3962+* ( adr --- adr )
3963+* Mask high bit of tail of name in PAD buffer.
3964+* Not in FIG, need it for 8 bit characters.
3965+ FCB $86
3966+ FCC 'IDFLA' ; 'IDFLAT'
3967+ FCB $D4 ; 'T'
3968+ FDB ERROR-8
3969+IDFLAT FDB *+NATWID
3970+ LDX ,U
3971+ LDB ,X ; get the count
3972+ ANDB #CTMASK
3973+ LDA B,X ; point to the tail
3974+ ANDA #$7F ; Clear the EndOfName flag bit.
3975+ STA B,X
3976+ RTS
3977+*
36973978 * ( symptr --- )
36983979 * Print definition's name from its NFA.
36993980 FCB $83
37003981 FCC 'ID' ; 'ID.'
37013982 FCB $AE
3702- FDB ERROR-8
3983+ FDB IDFLAT-9
37033984 IDDOT FDB DOCOL,PAD,LIT8
37043985 FCB 32
37053986 FDB LIT8
37063987 FCB $5F ( underline )
37073988 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
3708- FDB SWAP,CMOVE,PAD,COUNT,LIT8
3989+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
3990+ FDB SWAP,CMOVE,PAD
3991+ FDB IDFLAT
3992+ FDB COUNT,LIT8
37093993 FCB 31
37103994 FDB AND,TYPE,SPACE
37113995 FDB SEMIS
@@ -3724,7 +4008,7 @@ IDDOT FDB DOCOL,PAD,LIT8
37244008 FCB $C5
37254009 FDB IDDOT-6
37264010 CREATE FDB DOCOL,DFIND,ZBRAN
3727- FDB CREAT2-*
4011+ FDB CREAT2-*-NATWID
37284012 FDB DROP,PDOTQ
37294013 FCB 8
37304014 FCB 7 ( bel )
@@ -3764,7 +4048,7 @@ BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
37644048 FCB $CC
37654049 FDB BCOMP-12
37664050 LITER FDB DOCOL,STATE,AT,ZBRAN
3767- FDB LITER2-*
4051+ FDB LITER2-*-NATWID
37684052 FDB COMPIL,LIT,COMMA
37694053 LITER2 FDB SEMIS
37704054 *
@@ -3777,7 +4061,7 @@ LITER2 FDB SEMIS
37774061 FCB $CC
37784062 FDB LITER-10
37794063 DLITER FDB DOCOL,STATE,AT,ZBRAN
3780- FDB DLITE2-*
4064+ FDB DLITE2-*-NATWID
37814065 FDB SWAP,LITER,LITER ; Just two literals in the right order.
37824066 DLITE2 FDB SEMIS
37834067 *
@@ -3795,22 +4079,22 @@ DLITE2 FDB SEMIS
37954079 FDB DLITER-11
37964080 INTERP FDB DOCOL
37974081 INTER2 FDB DFIND,ZBRAN
3798- FDB INTER5-*
4082+ FDB INTER5-*-NATWID
37994083 FDB STATE,AT,LESS
38004084 FDB ZBRAN
3801- FDB INTER3-*
4085+ FDB INTER3-*-NATWID
38024086 FDB CFA,COMMA,BRAN
3803- FDB INTER4-*
4087+ FDB INTER4-*-NATWID
38044088 INTER3 FDB CFA,EXEC
38054089 INTER4 FDB BRAN
3806- FDB INTER7-*
4090+ FDB INTER7-*-NATWID
38074091 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
3808- FDB INTER6-*
4092+ FDB INTER6-*-NATWID
38094093 FDB DLITER,BRAN
3810- FDB INTER7-*
4094+ FDB INTER7-*-NATWID
38114095 INTER6 FDB DROP,LITER
38124096 INTER7 FDB QSTACK,BRAN
3813- FDB INTER2-*
4097+ FDB INTER2-*-NATWID
38144098 * FDB SEMIS never executed
38154099
38164100 *
@@ -3894,12 +4178,12 @@ QUIT FDB DOCOL,ZERO,BLK,STORE
38944178 * then repeats :
38954179 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
38964180 FDB ZBRAN
3897- FDB QUIT3-*
4181+ FDB QUIT3-*-NATWID
38984182 FDB PDOTQ
38994183 FCB 3
39004184 FCC ' OK' ; ' OK'
39014185 QUIT3 FDB BRAN
3902- FDB QUIT2-*
4186+ FDB QUIT2-*-NATWID
39034187 * FDB SEMIS ( never executed )
39044188 *
39054189 * ======>> 156 <<
@@ -3918,8 +4202,8 @@ QUIT3 FDB BRAN
39184202 FCB $D4
39194203 FDB QUIT-7
39204204 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
3921- FCB 8
3922- FCC "Forth-68"
4205+ FCB 10
4206+ FCC "Forth-6809"
39234207 FDB FORTH,DEFIN
39244208 FDB QUIT
39254209 * FDB SEMIS never executed
@@ -3992,7 +4276,7 @@ WENT LDS SINIT,PCR ; Get a useable return stack, at least.
39924276 PSHS X ; for loop termination
39934277 CLRB ; Yes, I'm being a little ridiculous. Only a little.
39944278 TFR D,Y
3995- LEAY XFENCE,Y ; top of destination
4279+ LEAY XFENCE-UORIG,Y ; top of destination
39964280 LEAX FENCIN,PCR ; top of stuff to move
39974281 WARM2 LDD ,--X ; All entries are 16 bit.
39984282 STD ,--Y
@@ -4014,7 +4298,7 @@ WARM2 LDD ,--X ; All entries are 16 bit.
40144298 * UP is already there (DP).
40154299 * LDX #ABORT
40164300 * STX IP
4017- LEAY ABORT,PCR ; Prepare IP.
4301+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
40184302 *
40194303 NOP Here is a place to jump to special user
40204304 NOP initializations such as I/0 interrups
@@ -4023,7 +4307,7 @@ WARM2 LDD ,--X ; All entries are 16 bit.
40234307 * For systems with TRACE:
40244308 LDX #00
40254309 * STX TRLIM clear trace mode
4026- STX <TRLIM clear trace mode
4310+ STX <TRLIM clear trace mode (both bytes)
40274311 LDX #0
40284312 * STX BRKPT clear breakpoint address
40294313 STX <BRKPT clear breakpoint address
@@ -4164,7 +4448,7 @@ MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
41644448 FCB $D3
41654449 FDB MSMOD-8
41664450 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
4167- FDB ABS2-*
4451+ FDB ABS2-*-NATWID
41684452 FDB MINUS
41694453 ABS2 FDB SEMIS
41704454 *
@@ -4177,7 +4461,7 @@ ABS2 FDB SEMIS
41774461 FCB $D3
41784462 FDB ABS-6
41794463 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
4180- FDB DABS2-*
4464+ FDB DABS2-*-NATWID
41814465 FDB DMINUS
41824466 DABS2 FDB SEMIS
41834467 *
@@ -4216,7 +4500,7 @@ PREV FDB DOCON
42164500 PBUF FDB DOCOL,LIT8
42174501 FCB $84
42184502 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
4219- FDB PBUF2-*
4503+ FDB PBUF2-*-NATWID
42204504 FDB DROP,FIRST
42214505 PBUF2 FDB DUP,PREV,AT,SUB
42224506 FDB SEMIS
@@ -4284,10 +4568,10 @@ DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
42844568 FDB DRONE-6
42854569 BUFFER FDB DOCOL,USE,AT,DUP,TOR
42864570 BUFFR2 FDB PBUF,ZBRAN
4287- FDB BUFFR2-*
4571+ FDB BUFFR2-*-NATWID
42884572 FDB USE,STORE,R,AT,ZLESS
42894573 FDB ZBRAN
4290- FDB BUFFR3-*
4574+ FDB BUFFR3-*-NATWID
42914575 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
42924576 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
42934577 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
@@ -4306,13 +4590,13 @@ BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
43064590 FDB BUFFER-9
43074591 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
43084592 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
4309- FDB BLOCK5-*
4593+ FDB BLOCK5-*-NATWID
43104594 BLOCK3 FDB PBUF,ZEQU,ZBRAN
4311- FDB BLOCK4-*
4595+ FDB BLOCK4-*-NATWID
43124596 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
43134597 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
43144598 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
4315- FDB BLOCK3-*
4599+ FDB BLOCK3-*-NATWID
43164600 FDB DUP,PREV,STORE
43174601 * BLOCK5 FDB FROMR,DROP,TWOP
43184602 BLOCK5 FDB FROMR,DROP,NATP
@@ -4357,13 +4641,13 @@ DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
43574641 FCB $C5
43584642 FDB DLINE-8
43594643 MESS FDB DOCOL,WARN,AT,ZBRAN
4360- FDB MESS3-*
4644+ FDB MESS3-*-NATWID
43614645 FDB DDUP,ZBRAN
4362- FDB MESS3-*
4646+ FDB MESS3-*-NATWID
43634647 FDB LIT8
43644648 FCB 4
43654649 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
4366- FDB MESS4-*
4650+ FDB MESS4-*-NATWID
43674651 MESS3 FDB PDOTQ
43684652 FCB 6
43694653 FCC 'err # ' ; 'err # '
@@ -4401,14 +4685,14 @@ ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
44014685 * called by words 13 through 16 in the dictionary.
44024686 *
44034687 * ======>> 182 << code for EMIT
4404-* ( c --- )
4405-* output using rom CHROUT: redirectable to a printer on Coco.
4688+* ( --- ) No parameter stack effect.
4689+* Interfaces directly with ROM. Expects output character in D (therefore, B).
4690+* Output using rom CHROUT: redirectable to a printer on Coco.
44064691 * Outputs the character on stack (low byte of 1 bit word/cell).
4407-PEMIT PULU D
4408-PEMITW TFR B,A ; Coco ROM wants it in A.
4409- PSHS Y,U,DP ; Save everything important!
4692+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
4693+ TFR B,A ; Coco ROM wants it in A.
44104694 CLRB
4411- TFR B,DP ; Give the ROM it's direct page.
4695+ TFR B,DP ; Give the ROM its direct page.
44124696 JSR [$A002] ; Output the character in A.
44134697 PULS Y,U,DP,PC
44144698 * PEMIT STB N save B
@@ -4427,10 +4711,11 @@ PEMITW TFR B,A ; Coco ROM wants it in A.
44274711 * PEMIT JMP $D286 for Smoke Signal DOS
44284712 *
44294713 * ======>> 183 << code for KEY
4430-* ( --- c )
4431-* wait for key from POLCAT on Coco.
4714+* ( --- ) No parameter stack effect.
4715+* Returns character or break flag in D, since this interfaces with Coco ROM.
4716+* Wait for key from POLCAT on Coco.
44324717 * Returns the character code for the key pressed.
4433-PKEY PSHS Y,U,DP
4718+PKEY PSHS Y,U,DP ; Must save everything important for this one.
44344719 LDA #$CF ; a cursor of sorts
44354720 CLRB
44364721 TFR B,DP
@@ -4439,15 +4724,16 @@ PKEY PSHS Y,U,DP
44394724 LDB ,X ; save glyph
44404725 STA ,X
44414726 PKEYLP JSR [$A000]
4727+ STA $41A ; DBG!
44424728 BEQ PKEYLP
4443- STB ,X ; restore
4444-PKEYR CLRB ; for the break flag
4729+ STD $418 ; DBG!
4730+ STB ,X ; restore
4731+PKEYR CLRB ; for the break flag, shares code with PQTER
44454732 CMPA #3 ; break key
44464733 BNE PKEYGT
44474734 COMB ; for the break flag
4448-PKEYGT EXG A,B
4449- PSHU D
4450- PULS Y,U,DP,PC
4735+PKEYGT EXG A,B ; Leave it in D for return.
4736+ PULS Y,U,DP,PC ; Shares exit with PQTER
44514737 SETDP IUPDP
44524738 * PKEY STB N
44534739 * STX N+1
@@ -4467,7 +4753,7 @@ PKEYGT EXG A,B
44674753 *
44684754 * ######>> screen 64 <<
44694755 * ======>> 184 << code for ?TERMINAL
4470-* ( --- f )
4756+* ( --- f ) Should change this to no stack effect.
44714757 * check break key using POLCAT
44724758 * Returns a flag to tell whether the break key was pressed or not.
44734759 PQTER PSHS Y,U,DP
@@ -4487,11 +4773,12 @@ PQTER PSHS Y,U,DP
44874773 PAGE
44884774 *
44894775 * ======>> 185 << code for CR
4490-* ( --- )
4776+* ( --- ) No stack effect.
4777+* Interfaces directly with ROM.
44914778 * For Coco just output a CR.
44924779 * Also subject to redirection in Coco BASIC ROM.
44934780 PCR LDB #$0D
4494- BRA PEMITW
4781+ BRA PEMIT ; Just steal the code.
44954782 * PCR LDA #$D carriage return
44964783 * BSR PEMIT
44974784 * LDA #$A line feed
@@ -4579,13 +4866,13 @@ HI FDB DOCON
45794866 FCB $D7
45804867 FDB HI-5
45814868 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
4582- FDB RW2-*
4869+ FDB RW2-*-NATWID
45834870 FDB PDOTQ
45844871 FCB 8
45854872 FCC ' Range ?' ; ' Range ?'
45864873 FDB QUIT
45874874 RW2 FDB FROMR,ZBRAN
4588- FDB RW3-*
4875+ FDB RW3-*-NATWID
45894876 FDB SWAP
45904877 RW3 FDB BBUF,CMOVE
45914878 FDB SEMIS
@@ -4681,7 +4968,8 @@ FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
46814968 FCC 'BAC' ; 'BACK'
46824969 FCB $CB
46834970 FDB FORGET-9
4684-BACK FDB DOCOL,HERE,SUB,COMMA
4971+* BACK FDB DOCOL,HERE,SUB,COMMA
4972+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
46854973 FDB SEMIS
46864974 *
46874975 * ======>> 195 <<
@@ -4713,7 +5001,7 @@ BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
47135001 FCB $C6
47145002 FDB BEGIN-8
47155003 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
4716- FDB OVER,SUB,SWAP,STORE
5004+ FDB OVER,NATP,SUB,SWAP,STORE
47175005 FDB SEMIS
47185006 *
47195007 * ======>> 197 <<
@@ -4899,10 +5187,10 @@ WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
48995187 FCB $D3
49005188 FDB WHILE-8
49015189 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
4902- FDB SPACE3-*
5190+ FDB SPACE3-*-NATWID
49035191 FDB ZERO,XDO
49045192 SPACE2 FDB SPACE,XLOOP
4905- FDB SPACE2-*
5193+ FDB SPACE2-*-NATWID
49065194 SPACE3 FDB SEMIS
49075195 *
49085196 * ======>> 209 <<
@@ -4937,7 +5225,7 @@ EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
49375225 FCB $CE
49385226 FDB EDIGS-5
49395227 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
4940- FDB SIGN2-*
5228+ FDB SIGN2-*-NATWID
49415229 FDB LIT8
49425230 FCC "-"
49435231 FDB HOLD
@@ -4953,7 +5241,7 @@ SIGN2 FDB SEMIS
49535241 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
49545242 FCB 9
49555243 FDB OVER,LESS,ZBRAN
4956- FDB DIG2-*
5244+ FDB DIG2-*-NATWID
49575245 FDB LIT8
49585246 FCB 7
49595247 FDB PLUS
@@ -4972,7 +5260,7 @@ DIG2 FDB LIT8
49725260 FDB DIG-4
49735261 DIGS FDB DOCOL
49745262 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
4975- FDB DIGS2-*
5263+ FDB DIGS2-*-NATWID
49765264 FDB SEMIS
49775265 *
49785266 * ######>> screen 76 <<
@@ -5038,6 +5326,7 @@ QUEST FDB DOCOL,AT,DOT
50385326 * ( n --- )
50395327 * Print out screen n as a field of ASCII,
50405328 * with line numbers in decimal.
5329+* Needs a console more than 70 characters wide.
50415330 FCB $84
50425331 FCC 'LIS' ; 'LIST'
50435332 FCB $D4
@@ -5050,7 +5339,7 @@ LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
50505339 FDB ZERO,XDO
50515340 LIST2 FDB CR,I,THREE
50525341 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
5053- FDB LIST2-*
5342+ FDB LIST2-*-NATWID
50545343 FDB CR
50555344 FDB SEMIS
50565345 *
@@ -5058,6 +5347,7 @@ LIST2 FDB CR,I,THREE
50585347 * ( start end --- )
50595348 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
50605349 * from start to end.
5350+* Needs a console more than 70 characters wide.
50615351 FCB $85
50625352 FCC 'INDE' ; 'INDEX'
50635353 FCB $D8
@@ -5066,16 +5356,17 @@ INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
50665356 INDEX2 FDB CR,I,THREE
50675357 FDB DOTR,SPACE,ZERO,I,DLINE
50685358 FDB QTERM,ZBRAN
5069- FDB INDEX3-*
5359+ FDB INDEX3-*-NATWID
50705360 FDB LEAVE
50715361 INDEX3 FDB XLOOP
5072- FDB INDEX2-*
5362+ FDB INDEX2-*-NATWID
50735363 FDB SEMIS
50745364 *
50755365 * ======>> 221 <<
50765366 * ( n --- )
50775367 * List a printer page full of screens.
50785368 * Line and screen number are in current base.
5369+* Needs a console more than 70 characters wide.
50795370 FCB $85
50805371 FCC 'TRIA' ; 'TRIAD'
50815372 FCB $C4
@@ -5084,10 +5375,10 @@ TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
50845375 FDB THREE,OVER,PLUS,SWAP,XDO
50855376 TRIAD2 FDB CR,I
50865377 FDB LIST,QTERM,ZBRAN
5087- FDB TRIAD3-*
5378+ FDB TRIAD3-*-NATWID
50885379 FDB LEAVE
50895380 TRIAD3 FDB XLOOP
5090- FDB TRIAD2-*
5381+ FDB TRIAD2-*-NATWID
50915382 FDB CR,LIT8
50925383 FCB $0F
50935384 FDB MESS,CR
@@ -5097,6 +5388,7 @@ TRIAD3 FDB XLOOP
50975388 * ======>> 222 <<
50985389 * ( --- )
50995390 * Alphabetically list the definitions in the current vocabulary.
5391+* Expects to output to printer, not TRS80 Color Computer screen.
51005392 FCB $85
51015393 FCC 'VLIS' ; 'VLIST'
51025394 FCB $D4
@@ -5107,21 +5399,85 @@ VLIST FDB DOCOL,LIT8
51075399 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
51085400 FCB 32
51095401 FDB SUB,GREAT,ZBRAN
5110- FDB VLIST2-*
5402+ FDB VLIST2-*-NATWID
51115403 FDB CR,ZERO,OUT,STORE
51125404 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
51135405 FDB DUP,ZEQU,QTERM,OR,ZBRAN
5114- FDB VLIST1-*
5406+ FDB VLIST1-*-NATWID
51155407 FDB DROP
51165408 FDB SEMIS
51175409 *
5410+* Need some utility stuff that isn't in the fig FORTH:
5411+* ( c --- )
5412+* Emit dot if c is less than blank, else emit c
5413+ FCB $85
5414+ FCC 'BEMI' ; 'BEMIT'
5415+ FCB $D4 ; 'T'
5416+ FDB VLIST-8
5417+BEMIT FDB DOCOL
5418+ FDB DUP,BL,LESS,ZBRAN
5419+ FDB BEMITO-*-NATWID
5420+ FDB DROP,LIT8
5421+ FCB $2e ; '.'
5422+BEMITO FDB EMIT
5423+ FDB SEMIS
5424+*
5425+* ( n width --- )
5426+* Output n in hexadecimal field width.
5427+ FCB $83
5428+ FCC 'X.' ; 'X.R'
5429+ FCB $D2 ; 'R'
5430+ FDB BEMIT-8
5431+XDOTR FDB DOCOL
5432+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
5433+ FDB SEMIS
5434+*
5435+* ( adr --- )
5436+* Dump a line of 4 bytes in memory, in hex and as characters.
5437+ FCB $85
5438+ FCC 'BLIN' ; 'BLINE'
5439+ FCB $C5 ; 'E'
5440+ FDB XDOTR-6
5441+BLINE FDB DOCOL
5442+ FDB DUP,LIT8
5443+ FCB 4
5444+ FDB PLUS,OVER,XDO
5445+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
5446+ FDB BLINEX-*-NATWID
5447+ FDB SPACE,SPACE
5448+ FDB DUP,LIT8
5449+ FCB 4
5450+ FDB SWAP,XDO
5451+BLINEC FDB I,CAT,BEMIT,XLOOP
5452+ FDB BLINEC-*-NATWID
5453+ FDB SEMIS
5454+*
5455+* ( start end --- )
5456+* Dump 4 byte lines from start to end.
5457+ FCB $85
5458+ FCC 'BDUM' ; 'BDUMP'
5459+ FCB $D0 ; '5'
5460+ FDB BLINE-8
5461+BDUMP FDB DOCOL
5462+ FDB XDO
5463+BDUMPL FDB I,LIT8
5464+ FCB 4
5465+ FDB XDOTR,LIT8
5466+ FCB $3A
5467+ FDB EMIT,SPACE
5468+ FDB I,BLINE,CR,LIT8
5469+ FCB 4
5470+ FDB XPLOOP
5471+ FDB BDUMPL-*-NATWID
5472+ FDB SEMIS
5473+*
51185474 * ======>> XX <<
51195475 * ( --- )
5120-* Mostly for place holding.
5476+* Mostly for place holding (fig Forth).
51215477 FCB $84
51225478 FCC 'NOO' ; 'NOOP'
51235479 FCB $D0
5124- FDB VLIST-8
5480+ FDB BDUMP-8
51255481 NOOP FDB NEXT a useful no-op
51265482 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
51275483
--- /dev/null
+++ b/fig-forth-auto6809opt.list
@@ -0,0 +1,5647 @@
1+ (fig-forth-auto680):00001 OPT PRT
2+ (fig-forth-auto680):00002
3+ (fig-forth-auto680):00003 * fig-FORTH FOR 6809
4+ (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
5+ (fig-forth-auto680):00005
6+ (fig-forth-auto680):00006 * RELEASE 0
7+ (fig-forth-auto680):00007 * JAN 2019
8+ (fig-forth-auto680):00008 * WITH COMPILER SECURITY
9+ (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
10+ (fig-forth-auto680):00010 *
11+ (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
12+ (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
13+ (fig-forth-auto680):00013
14+ (fig-forth-auto680):00014 * This free/libre/open source publication is provided
15+ (fig-forth-auto680):00015 * through the courtesy of:
16+ (fig-forth-auto680):00016 * FORTH
17+ (fig-forth-auto680):00017 * INTEREST
18+ (fig-forth-auto680):00018 * GROUP
19+ (fig-forth-auto680):00019 * fig
20+ (fig-forth-auto680):00020 * and other interested parties.
21+ (fig-forth-auto680):00021
22+ (fig-forth-auto680):00022 * Ancient address:
23+ (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
24+ (fig-forth-auto680):00024 * URL: http://www.forth.org
25+ (fig-forth-auto680):00025 * Further distribution must include this notice.
26+ (fig-forth-auto680):00026 PAGE
27+ (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
28+ (fig-forth-auto680):00028 OPT NOG,PAG
29+ (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
30+ (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
31+ (fig-forth-auto680):00031
32+ (fig-forth-auto680):00032
33+ (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
34+ (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
35+ (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
36+ (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
37+ (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
38+ (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
39+ (fig-forth-auto680):00039 *
40+ (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
41+ (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
42+ (fig-forth-auto680):00042
43+ (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
44+ (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
45+ (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
46+ (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
47+ (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
48+ (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
49+ (fig-forth-auto680):00049 * THE SOFTWARE.
50+ (fig-forth-auto680):00050 *
51+ (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
52+ (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
53+ (fig-forth-auto680):00053 * or, if the code is split into multiple files,
54+ (fig-forth-auto680):00054 * all files containing the complete source.
55+ (fig-forth-auto680):00055 *
56+ (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
57+ (fig-forth-auto680):00057 * with associated documentation defined.
58+ (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
59+ (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
60+ (fig-forth-auto680):00060 *
61+ (fig-forth-auto680):00061
62+ (fig-forth-auto680):00062 * Authors of the 6800 model:
63+ (fig-forth-auto680):00063 * === Primary: Dave Lion,
64+ (fig-forth-auto680):00064 * === with help from
65+ (fig-forth-auto680):00065 * === Bob Smith,
66+ (fig-forth-auto680):00066 * === LaFarr Stuart,
67+ (fig-forth-auto680):00067 * === The Forth Interest Group
68+ (fig-forth-auto680):00068 * === PO Box 1105
69+ (fig-forth-auto680):00069 * === San Carlos, CA 94070
70+ (fig-forth-auto680):00070 * === and
71+ (fig-forth-auto680):00071 * === Unbounded Computing
72+ (fig-forth-auto680):00072 * === 1134-K Aster Ave.
73+ (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
74+ (fig-forth-auto680):00074 *
75+ 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
76+ (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
77+ (fig-forth-auto680):00077 * system using an ACIA for the I/O.
78+ (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
79+ (fig-forth-auto680):00079
80+ (fig-forth-auto680):00080 * All terminal 1/0
81+ (fig-forth-auto680):00081 * is done in three subroutines:
82+ (fig-forth-auto680):00082 * PEMIT ( word # 182 )
83+ (fig-forth-auto680):00083 * PKEY ( 183 )
84+ (fig-forth-auto680):00084 * PQTERM ( 184 )
85+ (fig-forth-auto680):00085 *
86+ (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
87+ (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
88+ (fig-forth-auto680):00088 * tested using a real disc.
89+ (fig-forth-auto680):00089 *
90+ (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
91+ (fig-forth-auto680):00091 * on the development system, it was convenient to
92+ (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
93+ (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
94+ (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
95+ (fig-forth-auto680):00095 * Minor deviations from the model were made in the
96+ (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
97+ (fig-forth-auto680):00097 * in order to do this.
98+ (fig-forth-auto680):00098 * Those deviations will be altered in this
99+ (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
100+ (fig-forth-auto680):00100 *
101+ (fig-forth-auto680):00101
102+ (fig-forth-auto680):00102 *
103+ 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
104+ 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
105+ 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
106+ FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
107+ FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
108+ (fig-forth-auto680):00108 PAGE
109+ (fig-forth-auto680):00109 * MEMORY MAP for this 16K|32K system:
110+ (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
111+ (fig-forth-auto680):00111 * protected segments can write protect FORTH )
112+ (fig-forth-auto680):00112 *
113+ (fig-forth-auto680):00113 * addr. contents pointer init by
114+ (fig-forth-auto680):00114 * **** ******************************* ******* ******
115+ (fig-forth-auto680):00115 * 2nd through 4th per-user tables
116+ (fig-forth-auto680):00116 * 4000|7D00
117+ 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
118+ 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
119+ 0004 (fig-forth-auto680):00119 USER32 EQU 4
120+ 0004 (fig-forth-auto680):00120 USERCT EQU USER32
121+ 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
122+ 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
123+ 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
124+ 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
125+ (fig-forth-auto680):00125 * user tables of variables
126+ (fig-forth-auto680):00126 * registers & pointers for the virtual machine
127+ (fig-forth-auto680):00127 * scratch area used by various words
128+ (fig-forth-auto680):00128 * 3F00|7C00 <== UP (DICTPT)
129+ (fig-forth-auto680):00129 * 3EFF|7BFF HI
130+ (fig-forth-auto680):00130 * substitute for disc mass memory
131+ 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
132+ 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
133+ (fig-forth-auto680):00133 * 3300|7000 LO,MEMEND
134+ 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
135+ 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
136+ 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
137+ 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
138+ 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
139+ 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
140+ (fig-forth-auto680):00140 * 32FF|6FFF
141+ (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
142+ 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
143+ (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
144+ (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
145+ (fig-forth-auto680):00145 * holding SECTSZ characters
146+ 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
147+ 0008 (fig-forth-auto680):00147 SECTRL EQU 8
148+ 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
149+ (fig-forth-auto680):00149 * 2EE0|6BE0 FIRST
150+ 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
151+ 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
152+ 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
153+ (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
154+ (fig-forth-auto680):00154 * 2EE0|6BE0 <== RP RINIT
155+ 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
156+ 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
157+ 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
158+ (fig-forth-auto680):00158 * RETURN STACK
159+ (fig-forth-auto680):00159 * (64|112 levels nesting)
160+ 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
161+ 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
162+ (fig-forth-auto680):00162 * (2E60|6B00)
163+ 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
164+ 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
165+ 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
166+ (fig-forth-auto680):00166 * INPUT LINE BUFFER
167+ (fig-forth-auto680):00167 * holds up to 256 characters
168+ (fig-forth-auto680):00168 * and is scanned upward by IN
169+ (fig-forth-auto680):00169 * starting at TIB
170+ 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
171+ (fig-forth-auto680):00171 * 2D60|6A00
172+ 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
173+ 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
174+ 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
175+ (fig-forth-auto680):00175 * 2D60|6A00 <== IN TIB
176+ 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
177+ 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
178+ 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
179+ (fig-forth-auto680):00179 * 2D60|6A00 <== SP SP0,SINIT
180+ (fig-forth-auto680):00180 * DATA STACK
181+ (fig-forth-auto680):00181 * | grows downward from 2A60|6A00
182+ (fig-forth-auto680):00182 * v
183+ (fig-forth-auto680):00183 * - -
184+ (fig-forth-auto680):00184 * |
185+ (fig-forth-auto680):00185 * I DICTIONARY grows upward
186+ (fig-forth-auto680):00186 *
187+ (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
188+ (fig-forth-auto680):00188 * "TASK"
189+ (fig-forth-auto680):00189 *
190+ (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
191+ (fig-forth-auto680):00191 * `==== CURRENT
192+ (fig-forth-auto680):00192 * start of ram-dictionary.
193+ (fig-forth-auto680):00193 *
194+ (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
195+ (fig-forth-auto680):00195 *
196+ (fig-forth-auto680):00196 * ????
197+ (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
198+ (fig-forth-auto680):00198 * <== W
199+ (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
200+ (fig-forth-auto680):00200 *
201+ (fig-forth-auto680):00201 * 1208 initialization tables
202+ (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
203+ (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
204+ (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
205+ (fig-forth-auto680):00205 *
206+ 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
207+ (fig-forth-auto680):00207 * CODEBG EQU $3000
208+ (fig-forth-auto680):00208 *
209+ (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
210+ (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
211+ (fig-forth-auto680):00211 *
212+ (fig-forth-auto680):00212 * 0000
213+ (fig-forth-auto680):00213 PAGE
214+ (fig-forth-auto680):00214 ***
215+ (fig-forth-auto680):00215 *
216+ (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
217+ (fig-forth-auto680):00217 *
218+ (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
219+ (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
220+ (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
221+ (fig-forth-auto680):00221 *
222+ (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
223+ (fig-forth-auto680):00223 *
224+ (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
225+ (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
226+ (fig-forth-auto680):00226 *
227+ (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
228+ (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
229+ (fig-forth-auto680):00229 *
230+ (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
231+ (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
232+ (fig-forth-auto680):00232 * to be executed/currently executing.
233+ (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
234+ (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
235+ (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
236+ (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
237+ (fig-forth-auto680):00237 *
238+ (fig-forth-auto680):00238 * ======
239+ (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
240+ (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
241+ (fig-forth-auto680):00241 * to save code and time in leaf routines.
242+ (fig-forth-auto680):00242 *
243+ (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
244+ (fig-forth-auto680):00244 * from assembly language code.
245+ (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
246+ (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
247+ (fig-forth-auto680):00247 * ======
248+ (fig-forth-auto680):00248 *
249+ (fig-forth-auto680):00249 * boolean flags:
250+ (fig-forth-auto680):00250 * 0 is false, anything else is true.
251+ (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
252+ (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
253+ (fig-forth-auto680):00253 *
254+ (fig-forth-auto680):00254 ***
255+ (fig-forth-auto680):00255
256+ (fig-forth-auto680):00256 PAGE
257+ (fig-forth-auto680):00257 * This system is shown with one user (task),
258+ (fig-forth-auto680):00258 * but additional users (tasks) may be added
259+ (fig-forth-auto680):00259 * by allocating additional user tables:
260+ (fig-forth-auto680):00260 *
261+ (fig-forth-auto680):00261 ORG IUP
262+7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
263+7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
264+ (fig-forth-auto680):00264 *
265+ (fig-forth-auto680):00265 * Some of this stuff gets initialized during
266+ (fig-forth-auto680):00266 * COLD start and WARM start:
267+ (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
268+ (fig-forth-auto680):00268 *
269+ (fig-forth-auto680):00269 ORG IUP
270+ 7C00 (fig-forth-auto680):00270 UORIG EQU *
271+ (fig-forth-auto680):00271 * A few useful VM variables
272+ (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
273+ (fig-forth-auto680):00273 * All are replaced by 6809 registers.
274+ (fig-forth-auto680):00274
275+7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
276+ (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
277+ (fig-forth-auto680):00277
278+ (fig-forth-auto680):00278
279+ (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
280+ (fig-forth-auto680):00280
281+7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
282+7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
283+7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
284+ (fig-forth-auto680):00284 * the program will go into trace mode
285+7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
286+ (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
287+ (fig-forth-auto680):00287
288+ (fig-forth-auto680):00288
289+ (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
290+ (fig-forth-auto680):00290 * Starting at $OOFO:
291+ (fig-forth-auto680):00291
292+ (fig-forth-auto680):00292
293+7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
294+ (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
295+ (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
296+7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
297+7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
298+7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
299+ (fig-forth-auto680):00299 * ( altered during multi-tasking )
300+ (fig-forth-auto680):00300 *
301+ (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
302+7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
303+7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
304+7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
305+7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
306+7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
307+7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
308+7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
309+7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
310+7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
311+7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
312+7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
313+7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
314+7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
315+7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
316+7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
317+7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
318+7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
319+7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
320+7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
321+7C42 (fig-forth-auto680):00321 XFLD RMB 2
322+7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
323+7C46 (fig-forth-auto680):00323 XRNUM RMB 2
324+7C48 (fig-forth-auto680):00324 XHLD RMB 2
325+7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
326+7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
327+7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
328+7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
329+7C52 (fig-forth-auto680):00329 RMB 2
330+7C54 (fig-forth-auto680):00330 RMB 2
331+7C56 (fig-forth-auto680):00331 RMB 2
332+ (fig-forth-auto680):00332
333+ (fig-forth-auto680):00333
334+ (fig-forth-auto680):00334
335+ (fig-forth-auto680):00335
336+ (fig-forth-auto680):00336 *
337+ (fig-forth-auto680):00337 *
338+ (fig-forth-auto680):00338 * end of user table, start of common system variables
339+ (fig-forth-auto680):00339 *
340+ (fig-forth-auto680):00340 *
341+ (fig-forth-auto680):00341 *
342+7C58 (fig-forth-auto680):00342 XUSE RMB 2
343+7C5A (fig-forth-auto680):00343 XPREV RMB 2
344+7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
345+ (fig-forth-auto680):00345
346+ (fig-forth-auto680):00346 PAGE
347+ (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
348+ (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
349+ (fig-forth-auto680):00349 * but right now we're just getting it running.
350+ (fig-forth-auto680):00350 ORG CODEBG
351+ (fig-forth-auto680):00351
352+ (fig-forth-auto680):00352 * ######>> screen 3 <<
353+ (fig-forth-auto680):00353 *
354+ (fig-forth-auto680):00354 ***************************
355+ (fig-forth-auto680):00355 ** C O L D E N T R Y **
356+ (fig-forth-auto680):00356 ***************************
357+1200 12 (fig-forth-auto680):00357 ORIG NOP
358+ (fig-forth-auto680):00358 * JMP CENT
359+1201 171029 (fig-forth-auto680):00359 LBSR CENT
360+ (fig-forth-auto680):00360 ***************************
361+ (fig-forth-auto680):00361 ** W A R M E N T R Y **
362+ (fig-forth-auto680):00362 ***************************
363+1204 12 (fig-forth-auto680):00363 NOP
364+ (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
365+1205 171062 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
366+ 7C (fig-forth-auto680):00366 SETDP IUPDP
367+ (fig-forth-auto680):00367
368+ (fig-forth-auto680):00368 *
369+ (fig-forth-auto680):00369 ******* startup parmeters **************************
370+ (fig-forth-auto680):00370 *
371+1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
372+120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
373+ (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
374+120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
375+1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
376+ (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
377+1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
378+ (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
379+1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
380+ (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
381+1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
382+ (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
383+1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
384+121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
385+121C 2AD0 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
386+121E 2AD0 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
387+1220 2AA5 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
388+1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
389+1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
390+ (fig-forth-auto680):00390 ****************************************************
391+ (fig-forth-auto680):00391 *
392+ (fig-forth-auto680):00392 PAGE
393+ (fig-forth-auto680):00393 *
394+ (fig-forth-auto680):00394 * ######>> screen 13 <<
395+ (fig-forth-auto680):00395 * These were of questionable use anyway,
396+ (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
397+ (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
398+ (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
399+ (fig-forth-auto680):00399 * PULS B ;
400+ (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
401+ (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
402+ (fig-forth-auto680):00402 * STB 1,X
403+ (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
404+1226 2000 (fig-forth-auto680):00404 BRA NEXT
405+ (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
406+ (fig-forth-auto680):00406 * LDB 1,X
407+ (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
408+ (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
409+ (fig-forth-auto680):00409 * PSHS A ;
410+ (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
411+ (fig-forth-auto680):00411
412+ (fig-forth-auto680):00412
413+ (fig-forth-auto680):00413 *
414+ (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
415+ (fig-forth-auto680):00415 *
416+ (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
417+ (fig-forth-auto680):00417 *
418+ (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
419+ (fig-forth-auto680):00419 * =
420+ (fig-forth-auto680):00420 * NEXT itself might just completely go away.
421+ (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
422+ (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
423+ (fig-forth-auto680):00423 *
424+ (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
425+ (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
426+ (fig-forth-auto680):00426 * one at a time.
427+ (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
428+ (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
429+ (fig-forth-auto680):00429 * to the known beginning of the loop,
430+ (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
431+ (fig-forth-auto680):00431 *
432+ (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
433+ (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
434+ (fig-forth-auto680):00434 *
435+ (fig-forth-auto680):00435 * NEXT LDX IP
436+ (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
437+ (fig-forth-auto680):00437 * LEAX 1,X ;
438+ (fig-forth-auto680):00438 * STX IP
439+1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
440+ (fig-forth-auto680):00440 *
441+ (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
442+1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
443+122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
444+122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
445+ (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
446+ (fig-forth-auto680):00446 * NEXT3 STX W
447+122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
448+ (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
449+ (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
450+ (fig-forth-auto680):00450 * =
451+ (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
452+ (fig-forth-auto680):00452 * if a TRACE routine is available: =
453+ (fig-forth-auto680):00453 * =
454+ (fig-forth-auto680):00454 * JMP 0,X
455+ (fig-forth-auto680):00455
456+122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
457+ (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
458+ (fig-forth-auto680):00458 * NOP
459+ (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
460+1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
461+ (fig-forth-auto680):00461 * In other words, with the call and the NOP,
462+ (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
463+ (fig-forth-auto680):00463 * routine, which you have to provide.
464+1232 20F4 (fig-forth-auto680):00464 BRA NEXT
465+ (fig-forth-auto680):00465 *
466+1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
467+1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
468+1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
469+123A 301D (fig-forth-auto680):00469 LEAX -3,X
470+123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
471+123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
472+1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
473+1244 E680 (fig-forth-auto680):00473 LDB ,X+
474+1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
475+1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
476+124A E7A0 (fig-forth-auto680):00476 STB ,Y+
477+124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
478+124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
479+1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
480+1252 C660 (fig-forth-auto680):00480 LDB #$60
481+1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
482+1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
483+1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
484+125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
485+125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
486+ (fig-forth-auto680):00486 *
487+ (fig-forth-auto680):00487 *
488+1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
489+1261 54 (fig-forth-auto680):00489 LSRB
490+1262 54 (fig-forth-auto680):00490 LSRB
491+1263 54 (fig-forth-auto680):00491 LSRB
492+1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
493+1266 CB30 (fig-forth-auto680):00493 ADDB #$30
494+1268 C139 (fig-forth-auto680):00494 CMPB #$39
495+126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
496+126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
497+126E 39 (fig-forth-auto680):00497 MKhxBx RTS
498+ (fig-forth-auto680):00498 *
499+126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
500+1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
501+1273 1E89 (fig-forth-auto680):00501 EXG A,B
502+1275 39 (fig-forth-auto680):00502 RTS
503+ (fig-forth-auto680):00503 *
504+1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
505+1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
506+127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
507+127C E780 (fig-forth-auto680):00507 STB ,X+
508+127E E6E4 (fig-forth-auto680):00508 LDB ,S
509+1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
510+1282 E780 (fig-forth-auto680):00510 STB ,X+
511+1284 3584 (fig-forth-auto680):00511 PULS B,PC
512+ (fig-forth-auto680):00512 *
513+1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
514+1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
515+128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
516+128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
517+1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
518+1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
519+1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
520+1299 ED81 (fig-forth-auto680):00520 STD ,X++
521+129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
522+129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
523+12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
524+12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
525+12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
526+12A6 C660 (fig-forth-auto680):00526 LDB #$60
527+12A8 E780 (fig-forth-auto680):00527 STB ,X+
528+12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
529+12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
530+12AE C660 (fig-forth-auto680):00530 LDB #$60
531+12B0 E780 (fig-forth-auto680):00531 STB ,X+
532+12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
533+12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
534+12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
535+12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
536+12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
537+12BD C660 (fig-forth-auto680):00537 LDB #$60
538+12BF E780 (fig-forth-auto680):00538 STB ,X+
539+12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
540+12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
541+12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
542+12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
543+12C9 C660 (fig-forth-auto680):00543 LDB #$60
544+12CB E780 (fig-forth-auto680):00544 STB ,X+
545+12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
546+12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
547+12D1 C660 (fig-forth-auto680):00547 LDB #$60
548+12D3 E780 (fig-forth-auto680):00548 STB ,X+
549+12D5 E780 (fig-forth-auto680):00549 STB ,X+
550+12D7 E780 (fig-forth-auto680):00550 STB ,X+
551+12D9 E780 (fig-forth-auto680):00551 STB ,X+
552+12DB E780 (fig-forth-auto680):00552 STB ,X+
553+12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
554+12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
555+12E2 C660 (fig-forth-auto680):00555 LDB #$60
556+12E4 E780 (fig-forth-auto680):00556 STB ,X+
557+12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
558+12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
559+12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
560+12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
561+12EF C660 (fig-forth-auto680):00561 LDB #$60
562+12F1 E780 (fig-forth-auto680):00562 STB ,X+
563+12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
564+12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
565+12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
566+12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
567+12FF C660 (fig-forth-auto680):00567 LDB #$60
568+1301 E780 (fig-forth-auto680):00568 STB ,X+
569+1303 E780 (fig-forth-auto680):00569 STB ,X+
570+1305 E780 (fig-forth-auto680):00570 STB ,X+
571+1307 E780 (fig-forth-auto680):00571 STB ,X+
572+1309 E780 (fig-forth-auto680):00572 STB ,X+
573+130B C600 (fig-forth-auto680):00573 LDB #0
574+130D 1E9B (fig-forth-auto680):00574 EXG B,DP
575+130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
576+1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
577+1315 FD043E (fig-forth-auto680):00577 STD $43E
578+1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
579+131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
580+131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
581+131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
582+1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
583+1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
584+1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
585+1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
586+1328 D330 (fig-forth-auto680):00586 ADDD <XIN
587+132A 1F02 (fig-forth-auto680):00587 TFR D,Y
588+132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
589+132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
590+1331 E780 (fig-forth-auto680):00590 STB ,X+
591+1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
592+1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
593+1337 E780 (fig-forth-auto680):00593 STB ,X+
594+1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
595+133B 4A (fig-forth-auto680):00595 DBGRit DECA
596+133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
597+133E 202D (fig-forth-auto680):00597 BRA DBGRrt
598+1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
599+1342 2009 (fig-forth-auto680):00599 BRA DBGRst
600+1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
601+1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
602+1349 C660 (fig-forth-auto680):00602 LDB #$60
603+134B E780 (fig-forth-auto680):00603 STB ,X+
604+134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
605+1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
606+1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
607+1354 E780 (fig-forth-auto680):00607 STB ,X+
608+1356 C655 (fig-forth-auto680):00608 LDB #$55
609+1358 E780 (fig-forth-auto680):00609 STB ,X+
610+135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
611+135D 2009 (fig-forth-auto680):00611 BRA DBGRut
612+135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
613+1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
614+1364 C660 (fig-forth-auto680):00614 LDB #$60
615+1366 E780 (fig-forth-auto680):00615 STB ,X+
616+1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
617+136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
618+136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
619+136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
620+ 2020532020205520
621+ 2020205920202058
622+ 2020202041204220
623+138F 00000000 (fig-forth-auto680):00620 FDB 0,0
624+ (fig-forth-auto680):00621
625+ (fig-forth-auto680):00622
626+ (fig-forth-auto680):00623 *
627+ (fig-forth-auto680):00624 * =
628+ (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
629+ (fig-forth-auto680):00626
630+ (fig-forth-auto680):00627
631+ (fig-forth-auto680):00628 PAGE
632+ (fig-forth-auto680):00629 *
633+ (fig-forth-auto680):00630 * ======>> 1 <<
634+ (fig-forth-auto680):00631 * ( --- n )
635+ (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
636+ (fig-forth-auto680):00633 * as a literal, or immediate value.
637+ (fig-forth-auto680):00634 *
638+ (fig-forth-auto680):00635 * FDB {OP}
639+ (fig-forth-auto680):00636 * FDB {OP}
640+ (fig-forth-auto680):00637 * FDB LIT
641+ (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
642+ (fig-forth-auto680):00639 * FDB {OP}
643+ (fig-forth-auto680):00640 *
644+ (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
645+ (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
646+ (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
647+ (fig-forth-auto680):00644 *
648+ (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
649+ (fig-forth-auto680):00646 *
650+1393 83 (fig-forth-auto680):00647 FCB $83
651+1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
652+1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
653+1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
654+1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
655+139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
656+139D 3606 (fig-forth-auto680):00653 PSHU A,B
657+139F 39 (fig-forth-auto680):00654 RTS
658+ (fig-forth-auto680):00655 * LDX IP
659+ (fig-forth-auto680):00656 * LEAX 1,X ;
660+ (fig-forth-auto680):00657 * LEAX 1,X ;
661+ (fig-forth-auto680):00658 * STX IP
662+ (fig-forth-auto680):00659 * LDA 0,X
663+ (fig-forth-auto680):00660 * LDB 1,X
664+ (fig-forth-auto680):00661 * JMP PUSHBA
665+ (fig-forth-auto680):00662 *
666+ (fig-forth-auto680):00663 * ######>> screen 14 <<
667+ (fig-forth-auto680):00664 * ======>> 2 <<
668+ (fig-forth-auto680):00665 * ( --- n )
669+ (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
670+ (fig-forth-auto680):00667 * as a literal, or immediate value.
671+ (fig-forth-auto680):00668 *
672+ (fig-forth-auto680):00669 * FDB {OP}
673+ (fig-forth-auto680):00670 * FDB {OP}
674+ (fig-forth-auto680):00671 * FDB LIT8
675+ (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
676+ (fig-forth-auto680):00673 * FDB {OP}
677+ (fig-forth-auto680):00674 *
678+ (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
679+ (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
680+ (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
681+ (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
682+ (fig-forth-auto680):00679 * Also, see comments for LIT.
683+ (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
684+13A0 84 (fig-forth-auto680):00681 FCB $84
685+13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
686+13A4 B8 (fig-forth-auto680):00683 FCB $B8
687+13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
688+13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
689+13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
690+13AB 4F (fig-forth-auto680):00687 CLRA
691+13AC 3606 (fig-forth-auto680):00688 PSHU A,B
692+13AE 39 (fig-forth-auto680):00689 RTS
693+ (fig-forth-auto680):00690 * LDX IP
694+ (fig-forth-auto680):00691 * LEAX 1,X ;
695+ (fig-forth-auto680):00692 * STX IP
696+ (fig-forth-auto680):00693 * CLRA ;
697+ (fig-forth-auto680):00694 * LDB 1,X
698+ (fig-forth-auto680):00695 * JMP PUSHBA
699+ (fig-forth-auto680):00696 *
700+ (fig-forth-auto680):00697 * ( n off --- n )
701+ (fig-forth-auto680):00698 * off is offset in video buffer area.
702+13AF 87 (fig-forth-auto680):00699 FCB $87
703+13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
704+13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
705+13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
706+13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
707+13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
708+13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
709+13C0 308B (fig-forth-auto680):00706 LEAX D,X
710+13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
711+13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
712+13C7 39 (fig-forth-auto680):00709 RTS
713+ (fig-forth-auto680):00710 *
714+13C8 85 (fig-forth-auto680):00711 FCB $85
715+13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
716+13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'|$80
717+13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
718+13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
719+13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
720+13D4 39 (fig-forth-auto680):00717 RTS
721+ (fig-forth-auto680):00718 *
722+13D5 84 (fig-forth-auto680):00719 FCB $84
723+13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
724+13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'|$80
725+13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
726+13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
727+13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
728+13E0 39 (fig-forth-auto680):00725 RTS
729+ (fig-forth-auto680):00726 *
730+ (fig-forth-auto680):00727 * ======>> 3 <<
731+ (fig-forth-auto680):00728 * ( adr --- )
732+ (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
733+ (fig-forth-auto680):00730 * interactively invoke routines.
734+ (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
735+13E1 87 (fig-forth-auto680):00732 FCB $87
736+13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
737+13E8 C5 (fig-forth-auto680):00734 FCB $C5
738+13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
739+13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
740+13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
741+13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
742+ (fig-forth-auto680):00739 * TFR S,X ; TSX :
743+ (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
744+ (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
745+ (fig-forth-auto680):00742 * LEAS 1,S ;
746+ (fig-forth-auto680):00743 * JMP NEXT3
747+ (fig-forth-auto680):00744 *
748+ (fig-forth-auto680):00745 * ######>> screen 15 <<
749+ (fig-forth-auto680):00746 * ======>> 4 <<
750+ (fig-forth-auto680):00747 * ( --- ) C
751+ (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
752+ (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
753+ (fig-forth-auto680):00750 *
754+ (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
755+ (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
756+ (fig-forth-auto680):00753 * This is only for Forth code stream.
757+ (fig-forth-auto680):00754 * Also, see comments for LIT.
758+13F1 86 (fig-forth-auto680):00755 FCB $86
759+13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
760+13F7 C8 (fig-forth-auto680):00757 FCB $C8
761+13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
762+13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
763+ (fig-forth-auto680):00760
764+ (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
765+13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
766+13FE 39 (fig-forth-auto680):00763 RTS
767+ (fig-forth-auto680):00764 * ======>> 5 <<
768+ (fig-forth-auto680):00765 * ( f --- ) C
769+ (fig-forth-auto680):00766 * BRANCH if flag is zero.
770+ (fig-forth-auto680):00767 *
771+ (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
772+ (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
773+ (fig-forth-auto680):00770 * This is only for Forth code stream.
774+ (fig-forth-auto680):00771 * Also, see comments for LIT.
775+13FF 87 (fig-forth-auto680):00772 FCB $87
776+1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
777+1406 C8 (fig-forth-auto680):00774 FCB $C8
778+1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
779+1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
780+140B ECC1 (fig-forth-auto680):00777 LDD ,U++
781+140D 26ED (fig-forth-auto680):00778 BNE ZBNO
782+140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
783+1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
784+1413 39 (fig-forth-auto680):00781 RTS
785+ (fig-forth-auto680):00782 * PULS A ;
786+ (fig-forth-auto680):00783 * PULS B ;
787+ (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
788+ (fig-forth-auto680):00785 * ADDA ,S+ ;
789+ (fig-forth-auto680):00786 * BNE ZBNO
790+ (fig-forth-auto680):00787 * BCS ZBNO
791+ (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
792+ (fig-forth-auto680):00789 * LDB 3,X
793+ (fig-forth-auto680):00790 * LDA 2,X
794+ (fig-forth-auto680):00791 * ADDB IP+1
795+ (fig-forth-auto680):00792 * ADCA IP
796+ (fig-forth-auto680):00793 * STB IP+1
797+ (fig-forth-auto680):00794 * STA IP
798+ (fig-forth-auto680):00795 * JMP NEXT
799+ (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
800+ (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
801+ (fig-forth-auto680):00798 * LEAX 1,X ;
802+ (fig-forth-auto680):00799 * STX IP
803+ (fig-forth-auto680):00800 * JMP NEXT
804+ (fig-forth-auto680):00801 *
805+ (fig-forth-auto680):00802 * ######>> screen 16 <<
806+ (fig-forth-auto680):00803 * ======>> 6 <<
807+ (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
808+ (fig-forth-auto680):00805 * ( limit index *** )
809+ (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
810+ (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
811+ (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
812+ (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
813+ (fig-forth-auto680):00810 * return stack.
814+ (fig-forth-auto680):00811 *
815+ (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
816+ (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
817+ (fig-forth-auto680):00814 * This is only for Forth code stream.
818+ (fig-forth-auto680):00815 * Also, see comments for LIT.
819+1414 86 (fig-forth-auto680):00816 FCB $86
820+1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
821+141A A9 (fig-forth-auto680):00818 FCB $A9
822+141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
823+141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
824+141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
825+1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
826+1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
827+1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
828+1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
829+142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
830+142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
831+142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
832+1430 6E84 (fig-forth-auto680):00829 JMP ,X
833+ (fig-forth-auto680):00830 * CLRA ;
834+ (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
835+ (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
836+ (fig-forth-auto680):00833 *
837+ (fig-forth-auto680):00834 * ======>> 7 <<
838+ (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
839+ (fig-forth-auto680):00836 * ( limit index *** )
840+ (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
841+ (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
842+ (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
843+ (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
844+ (fig-forth-auto680):00841 * the limit to cause loop termination.
845+ (fig-forth-auto680):00842 *
846+ (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
847+ (fig-forth-auto680):00844 *
848+ (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
849+ (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
850+ (fig-forth-auto680):00847 * This is only for Forth code stream.
851+ (fig-forth-auto680):00848 * Also, see comments for LIT.
852+1432 87 (fig-forth-auto680):00849 FCB $87
853+1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
854+1439 A9 (fig-forth-auto680):00851 FCB $A9
855+143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
856+143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
857+143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
858+1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
859+1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
860+1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
861+1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
862+1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
863+144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
864+ (fig-forth-auto680):00861 *
865+ (fig-forth-auto680):00862 * This should work, but I want to use tested code.
866+ (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
867+ (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
868+ (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
869+ (fig-forth-auto680):00866 * ADDD ,S ; Count.
870+ (fig-forth-auto680):00867 * STD ,S ; Update.
871+ (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
872+ (fig-forth-auto680):00869 **
873+ (fig-forth-auto680):00870 ** I think this should work:
874+ (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
875+ (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
876+ (fig-forth-auto680):00873 * LDD ,Y++
877+ (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
878+ (fig-forth-auto680):00875 * JMP ,X
879+ (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
880+ (fig-forth-auto680):00877 * JMP ,X ; synthetic return
881+ (fig-forth-auto680):00878 *
882+ (fig-forth-auto680):00879 * This definitely should work:
883+ (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
884+ (fig-forth-auto680):00881 * BPL XPLOF ;
885+ (fig-forth-auto680):00882 * CMPD NATWID,S
886+ (fig-forth-auto680):00883 * BMI XPLONO
887+ (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
888+ (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
889+ (fig-forth-auto680):00886 * JMP ,X
890+ (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
891+ (fig-forth-auto680):00888 * BMI XPLOYE
892+ (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
893+ (fig-forth-auto680):00890 * JMP ,X ; synthetic return
894+ (fig-forth-auto680):00891 *
895+ (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
896+ (fig-forth-auto680):00893 * PULS A ; get increment
897+ (fig-forth-auto680):00894 * PULS B ;
898+ (fig-forth-auto680):00895 * XPLOP2 TSTA ;
899+ (fig-forth-auto680):00896 * BPL XPLOF forward looping
900+ (fig-forth-auto680):00897 * BSR XPLOPS
901+ (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
902+ (fig-forth-auto680):00899 * SBCB 5,X
903+ (fig-forth-auto680):00900 * SBCA 4,X
904+ (fig-forth-auto680):00901 * BPL ZBYES
905+ (fig-forth-auto680):00902 * BRA XPLONO fall through
906+ (fig-forth-auto680):00903 *
907+ (fig-forth-auto680):00904 * the subroutine :
908+ (fig-forth-auto680):00905 * XPLOPS LDX RP
909+ (fig-forth-auto680):00906 * ADDB 3,X add it to counter
910+ (fig-forth-auto680):00907 * ADCA 2,X
911+ (fig-forth-auto680):00908 * STB 3,X store new counter value
912+ (fig-forth-auto680):00909 * STA 2,X
913+ (fig-forth-auto680):00910 * RTS
914+ (fig-forth-auto680):00911 *
915+ (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
916+ (fig-forth-auto680):00913 * SUBB 5,X
917+ (fig-forth-auto680):00914 * SBCA 4,X
918+ (fig-forth-auto680):00915 * BMI ZBYES
919+ (fig-forth-auto680):00916 *
920+ (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
921+ (fig-forth-auto680):00918 * LEAX 1,X ;
922+ (fig-forth-auto680):00919 * LEAX 1,X ;
923+ (fig-forth-auto680):00920 * LEAX 1,X ;
924+ (fig-forth-auto680):00921 * STX RP
925+ (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
926+ (fig-forth-auto680):00923 *
927+ (fig-forth-auto680):00924 * ######>> screen 17 <<
928+ (fig-forth-auto680):00925 * ======>> 8 <<
929+ (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
930+ (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
931+144C 84 (fig-forth-auto680):00928 FCB $84
932+144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
933+1450 A9 (fig-forth-auto680):00930 FCB $A9
934+1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
935+1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
936+1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
937+1457 3706 (fig-forth-auto680):00934 PULU A,B
938+1459 3406 (fig-forth-auto680):00935 PSHS A,B
939+145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
940+145D ED62 (fig-forth-auto680):00937 STD NATWID,S
941+145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
942+ (fig-forth-auto680):00939 *
943+ (fig-forth-auto680):00940 * LDX RP
944+ (fig-forth-auto680):00941 * LEAX -1,X ;
945+ (fig-forth-auto680):00942 * LEAX -1,X ;
946+ (fig-forth-auto680):00943 * LEAX -1,X ;
947+ (fig-forth-auto680):00944 * LEAX -1,X ;
948+ (fig-forth-auto680):00945 * STX RP
949+ (fig-forth-auto680):00946 * PULS A ;
950+ (fig-forth-auto680):00947 * PULS B ;
951+ (fig-forth-auto680):00948 * STA 2,X
952+ (fig-forth-auto680):00949 * STB 3,X
953+ (fig-forth-auto680):00950 * PULS A ;
954+ (fig-forth-auto680):00951 * PULS B ;
955+ (fig-forth-auto680):00952 * STA 4,X
956+ (fig-forth-auto680):00953 * STB 5,X
957+ (fig-forth-auto680):00954 * JMP NEXT
958+ (fig-forth-auto680):00955 *
959+ (fig-forth-auto680):00956 * ======>> 9 <<
960+ (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
961+ (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
962+1461 81 (fig-forth-auto680):00959 FCB $81 I
963+1462 C9 (fig-forth-auto680):00960 FCB $C9
964+1463 144C (fig-forth-auto680):00961 FDB XDO-7
965+1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
966+1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
967+1469 3606 (fig-forth-auto680):00964 PSHU A,B
968+146B 39 (fig-forth-auto680):00965 RTS
969+ (fig-forth-auto680):00966 * LDX RP
970+ (fig-forth-auto680):00967 * LEAX 1,X ;
971+ (fig-forth-auto680):00968 * LEAX 1,X ;
972+ (fig-forth-auto680):00969 * JMP GETX
973+ (fig-forth-auto680):00970 *
974+ (fig-forth-auto680):00971 * ######>> screen 18 <<
975+ (fig-forth-auto680):00972 * ======>> 10 <<
976+ (fig-forth-auto680):00973 * ( c base --- false )
977+ (fig-forth-auto680):00974 * ( c base --- n true )
978+ (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
979+ (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
980+ (fig-forth-auto680):00977 * flag is returned.
981+146C 85 (fig-forth-auto680):00978 FCB $85
982+146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
983+1471 D4 (fig-forth-auto680):00980 FCB $D4
984+1472 1461 (fig-forth-auto680):00981 FDB I-4
985+1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
986+1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
987+1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
988+147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
989+147D 1083000A (fig-forth-auto680):00986 CMPD #$A
990+1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
991+1483 10830011 (fig-forth-auto680):00988 CMPD #$11
992+1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
993+1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
994+148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
995+148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
996+1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
997+1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
998+1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
999+1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
1000+149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
1001+149E 39 (fig-forth-auto680):00998 RTS NEXT
1002+149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
1003+14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
1004+14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
1005+ (fig-forth-auto680):01002 * TFR S,X ; TSX :
1006+ (fig-forth-auto680):01003 * LDA 3,X
1007+ (fig-forth-auto680):01004 * SUBA #$30 ascii zero
1008+ (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
1009+ (fig-forth-auto680):01006 * CMPA #$A
1010+ (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
1011+ (fig-forth-auto680):01008 * CMPA #$11
1012+ (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
1013+ (fig-forth-auto680):01010 * CMPA #$2B
1014+ (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
1015+ (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
1016+ (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
1017+ (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
1018+ (fig-forth-auto680):01015 * LDB #1 set flag
1019+ (fig-forth-auto680):01016 * STA 3,X store digit
1020+ (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
1021+ (fig-forth-auto680):01018 * JMP NEXT
1022+ (fig-forth-auto680):01019 * DIGIT2 CLRB ;
1023+ (fig-forth-auto680):01020 * LEAS 1,S ;
1024+ (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
1025+ (fig-forth-auto680):01022 * TFR S,X ; TSX :
1026+ (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
1027+ (fig-forth-auto680):01024 * BRA DIGIT1
1028+ (fig-forth-auto680):01025 *
1029+ (fig-forth-auto680):01026 * ######>> screen 19 <<
1030+ (fig-forth-auto680):01027 *
1031+ (fig-forth-auto680):01028 * The word definition format in the dictionary:
1032+ (fig-forth-auto680):01029 *
1033+ (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
1034+ (fig-forth-auto680):01031 *
1035+ (fig-forth-auto680):01032 * NFA (name field address):
1036+ (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
1037+ (fig-forth-auto680):01034 * char 1 Characters of symbol name.
1038+ (fig-forth-auto680):01035 * char 2
1039+ (fig-forth-auto680):01036 * ...
1040+ (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
1041+ (fig-forth-auto680):01038 * LFA (link field address):
1042+ (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
1043+ (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
1044+ (fig-forth-auto680):01041 * CFA (code field address):
1045+ (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
1046+ (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
1047+ (fig-forth-auto680):01044 * PFA (parameter field address):
1048+ (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
1049+ (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
1050+ (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
1051+ (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
1052+ (fig-forth-auto680):01049 *
1053+ (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
1054+ (fig-forth-auto680):01051
1055+ (fig-forth-auto680):01052 * Definition attributes:
1056+ 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
1057+ 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
1058+ 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
1059+ (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
1060+ (fig-forth-auto680):01057 *
1061+ (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
1062+ (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
1063+ (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
1064+ (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
1065+ (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
1066+ (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
1067+ (fig-forth-auto680):01064 *
1068+ (fig-forth-auto680):01065 * ======>> 11 <<
1069+ (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
1070+ (fig-forth-auto680):01067 * ( name vocptr --- false )
1071+ (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
1072+ (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
1073+ (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
1074+ (fig-forth-auto680):01071 * in the vocabulary to be searched.
1075+ (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
1076+14A6 86 (fig-forth-auto680):01073 FCB $86
1077+14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
1078+14AC A9 (fig-forth-auto680):01075 FCB $A9
1079+14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
1080+14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
1081+14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
1082+ (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
1083+ 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
1084+ 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
1085+ (fig-forth-auto680):01082 *
1086+ (fig-forth-auto680):01083 * INC <TRACEM
1087+ (fig-forth-auto680):01084 * LBSR DBGREG
1088+14B3 AEC4 (fig-forth-auto680):01085 LDX PD,U ; Start in on the vocabulary (NFA).
1089+14B5 10AE42 (fig-forth-auto680):01086 PFNDLP LDY PA0,U ; Point to the name to check against.
1090+14B8 E680 (fig-forth-auto680):01087 LDB ,X+ ; get dict name length byte
1091+14BA 1F98 (fig-forth-auto680):01088 TFR B,A ; Save it in case it matches.
1092+14BC C43F (fig-forth-auto680):01089 ANDB #CTMASK
1093+ (fig-forth-auto680):01090 * LBSR DBGREG
1094+14BE E1A0 (fig-forth-auto680):01091 CMPB ,Y+ ; Compare lengths
1095+ (fig-forth-auto680):01092 * LBSR DBGREG
1096+14C0 261C (fig-forth-auto680):01093 BNE PFNDUN
1097+14C2 E680 (fig-forth-auto680):01094 PFNDBR LDB ,X+
1098+14C4 5D (fig-forth-auto680):01095 TSTB ; ; Is high bit of character in dictionary entry set?
1099+ (fig-forth-auto680):01096 * LBSR DBGREG
1100+14C5 2A13 (fig-forth-auto680):01097 BPL PFNDCH
1101+ (fig-forth-auto680):01098 * LBSR DBGREG
1102+14C7 C47F (fig-forth-auto680):01099 ANDB #$7F ; Clear high bit from dictionary.
1103+14C9 E1A0 (fig-forth-auto680):01100 CMPB ,Y+ ; Compare "last" characters.
1104+ (fig-forth-auto680):01101 * LBSR DBGREG
1105+14CB 2717 (fig-forth-auto680):01102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
1106+14CD AE81 (fig-forth-auto680):01103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
1107+ (fig-forth-auto680):01104 * LBSR DBGREG
1108+14CF 26E4 (fig-forth-auto680):01105 BNE PFNDLP ; Continue if link not=0
1109+ (fig-forth-auto680):01106 *
1110+ (fig-forth-auto680):01107 * not found :
1111+14D1 3342 (fig-forth-auto680):01108 LEAU NATWID,U ; Return only false flag.
1112+14D3 CC0000 (fig-forth-auto680):01109 LDD #0
1113+14D6 EDC4 (fig-forth-auto680):01110 STD ,U
1114+ (fig-forth-auto680):01111 * LBSR DBGREG
1115+ (fig-forth-auto680):01112 * DEC <TRACEM
1116+14D8 35A0 (fig-forth-auto680):01113 PULS Y,PC
1117+ (fig-forth-auto680):01114 *
1118+14DA E1A0 (fig-forth-auto680):01115 PFNDCH CMPB ,Y+ ; Compare characters.
1119+ (fig-forth-auto680):01116 * LBSR DBGREG
1120+14DC 27E4 (fig-forth-auto680):01117 BEQ PFNDBR
1121+14DE (fig-forth-auto680):01118 PFNDUN
1122+14DE E680 (fig-forth-auto680):01119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
1123+ (fig-forth-auto680):01120 * LBSR DBGREG
1124+14E0 2AFC (fig-forth-auto680):01121 BPL PFNDSC
1125+ (fig-forth-auto680):01122 * LBSR DBGREG
1126+14E2 20E9 (fig-forth-auto680):01123 BRA PFNDLN
1127+ (fig-forth-auto680):01124 *
1128+ (fig-forth-auto680):01125 * found :
1129+ (fig-forth-auto680):01126 *
1130+14E4 3004 (fig-forth-auto680):01127 FOUND LEAX 2*NATWID,X
1131+ (fig-forth-auto680):01128 * LBSR DBGREG
1132+14E6 AF42 (fig-forth-auto680):01129 STX NATWID,U
1133+14E8 1F89 (fig-forth-auto680):01130 TFR A,B
1134+14EA 4F (fig-forth-auto680):01131 CLRA
1135+14EB EDC4 (fig-forth-auto680):01132 STD ,U
1136+ (fig-forth-auto680):01133 * LBSR DBGREG
1137+14ED C601 (fig-forth-auto680):01134 LDB #1
1138+14EF 3606 (fig-forth-auto680):01135 PSHU A,B
1139+ (fig-forth-auto680):01136 * LBSR DBGREG
1140+ (fig-forth-auto680):01137 * DEC <TRACEM
1141+14F1 35A0 (fig-forth-auto680):01138 PULS Y,PC
1142+ (fig-forth-auto680):01139 *
1143+ (fig-forth-auto680):01140 * 6800 model:
1144+ (fig-forth-auto680):01141 * NOP ; Probably leftovers from a debugging session.
1145+ (fig-forth-auto680):01142 * NOP
1146+ (fig-forth-auto680):01143 * PD EQU N ptr to dict word being checked
1147+ (fig-forth-auto680):01144 * PA0 EQU N+2
1148+ (fig-forth-auto680):01145 * PA EQU N+4
1149+ (fig-forth-auto680):01146 * PC EQU N+6
1150+ (fig-forth-auto680):01147 * LDX #PD
1151+ (fig-forth-auto680):01148 * LDB #4
1152+ (fig-forth-auto680):01149 * PFIND0 PULS A ; loop to get arguments
1153+ (fig-forth-auto680):01150 * STA 0,X
1154+ (fig-forth-auto680):01151 * LEAX 1,X ;
1155+ (fig-forth-auto680):01152 * DECB ;
1156+ (fig-forth-auto680):01153 * BNE PFIND0
1157+ (fig-forth-auto680):01154 *
1158+ (fig-forth-auto680):01155 * LDX PD
1159+ (fig-forth-auto680):01156 * PFNDLP LDB 0,X get count dict count
1160+ (fig-forth-auto680):01157 * STB PC
1161+ (fig-forth-auto680):01158 * ANDB #$3F
1162+ (fig-forth-auto680):01159 * LEAX 1,X ;
1163+ (fig-forth-auto680):01160 * STX PD update PD
1164+ (fig-forth-auto680):01161 * LDX PA0
1165+ (fig-forth-auto680):01162 * LDA 0,X get count from arg
1166+ (fig-forth-auto680):01163 * LEAX 1,X ;
1167+ (fig-forth-auto680):01164 * STX PA intialize PA
1168+ (fig-forth-auto680):01165 * PSHS B ; ** emulating CBA:
1169+ (fig-forth-auto680):01166 * CMPA ,S+ ; compare lengths
1170+ (fig-forth-auto680):01167 * BNE PFNDUN
1171+ (fig-forth-auto680):01168 * PFNDBR LDX PA
1172+ (fig-forth-auto680):01169 * LDA 0,X
1173+ (fig-forth-auto680):01170 * LEAX 1,X ;
1174+ (fig-forth-auto680):01171 * STX PA
1175+ (fig-forth-auto680):01172 * LDX PD
1176+ (fig-forth-auto680):01173 * LDB 0,X
1177+ (fig-forth-auto680):01174 * LEAX 1,X ;
1178+ (fig-forth-auto680):01175 * STX PD
1179+ (fig-forth-auto680):01176 * TSTB ; is dict entry neg. ?
1180+ (fig-forth-auto680):01177 * BPL PFNDCH
1181+ (fig-forth-auto680):01178 * ANDB #$7F clear sign
1182+ (fig-forth-auto680):01179 * PSHS B ; ** emulating CBA:
1183+ (fig-forth-auto680):01180 * CMPA ,S+ ;
1184+ (fig-forth-auto680):01181 * BEQ FOUND
1185+ (fig-forth-auto680):01182 * PFNDLN LDX 0,X get new link
1186+ (fig-forth-auto680):01183 * BNE PFNDLP continue if link not=0
1187+ (fig-forth-auto680):01184 *
1188+ (fig-forth-auto680):01185 * not found :
1189+ (fig-forth-auto680):01186 *
1190+ (fig-forth-auto680):01187 * CLRA ;
1191+ (fig-forth-auto680):01188 * CLRB ;
1192+ (fig-forth-auto680):01189 * JMP PUSHBA
1193+ (fig-forth-auto680):01190 * PFNDCH PSHS B ; ** emulating CBA:
1194+ (fig-forth-auto680):01191 * CMPA ,S+ ;
1195+ (fig-forth-auto680):01192 * BEQ PFNDBR
1196+ (fig-forth-auto680):01193 * PFNDUN LDX PD
1197+ (fig-forth-auto680):01194 * PFNDSC LDB 0,X scan forward to end of this name
1198+ (fig-forth-auto680):01195 * LEAX 1,X ;
1199+ (fig-forth-auto680):01196 * BPL PFNDSC
1200+ (fig-forth-auto680):01197 * BRA PFNDLN
1201+ (fig-forth-auto680):01198 *
1202+ (fig-forth-auto680):01199 * found :
1203+ (fig-forth-auto680):01200 *
1204+ (fig-forth-auto680):01201 * FOUND LDA PD compute CFA
1205+ (fig-forth-auto680):01202 * LDB PD+1
1206+ (fig-forth-auto680):01203 * ADDB #4
1207+ (fig-forth-auto680):01204 * ADCA #0
1208+ (fig-forth-auto680):01205 * PSHS B ;
1209+ (fig-forth-auto680):01206 * PSHS A ;
1210+ (fig-forth-auto680):01207 * LDA PC
1211+ (fig-forth-auto680):01208 * PSHS A ;
1212+ (fig-forth-auto680):01209 * CLRA ;
1213+ (fig-forth-auto680):01210 * PSHS A ;
1214+ (fig-forth-auto680):01211 * LDB #1
1215+ (fig-forth-auto680):01212 * JMP PUSHBA
1216+ (fig-forth-auto680):01213 *
1217+ (fig-forth-auto680):01214 * PSHS A ; Left over from a stray copy-paste, I guess.
1218+ (fig-forth-auto680):01215 * CLRA ;
1219+ (fig-forth-auto680):01216 * PSHS A ;
1220+ (fig-forth-auto680):01217 * LDB #1
1221+ (fig-forth-auto680):01218 * JMP PUSHBA
1222+ (fig-forth-auto680):01219 *
1223+ (fig-forth-auto680):01220 * ######>> screen 20 <<
1224+ (fig-forth-auto680):01221 * ======>> 12 <<
1225+ (fig-forth-auto680):01222 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
1226+ (fig-forth-auto680):01223 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
1227+ (fig-forth-auto680):01224 * ( buffer ch --- buffer nuloffset onepast scancount )
1228+ (fig-forth-auto680):01225 * Scan buffer for a symbol delimited by ch or ASCII NUL,
1229+ (fig-forth-auto680):01226 * return the length of the buffer region scanned,
1230+ (fig-forth-auto680):01227 * the offset to the trailing delimiter,
1231+ (fig-forth-auto680):01228 * and the offset of the first character of the symbol.
1232+ (fig-forth-auto680):01229 * Leave the buffer on the stack.
1233+ (fig-forth-auto680):01230 * Scancount is also offset to first character not yet looked at.
1234+ (fig-forth-auto680):01231 * If no symbol in buffer, scancount and symboloffset point to NUL
1235+ (fig-forth-auto680):01232 * and delimiteroffset points one beyond for some reason.
1236+ (fig-forth-auto680):01233 * On trailing NUL, delimiteroffset == scancount.
1237+ (fig-forth-auto680):01234 * (Buffer is the address of the buffer array to scan.)
1238+ (fig-forth-auto680):01235 * (This is a bit too tricky, really.)
1239+14F3 87 (fig-forth-auto680):01236 FCB $87
1240+14F4 454E434C4F53 (fig-forth-auto680):01237 FCC 'ENCLOS' ; 'ENCLOSE'
1241+14FA C5 (fig-forth-auto680):01238 FCB $C5
1242+14FB 14A6 (fig-forth-auto680):01239 FDB PFIND-9
1243+14FD 14FF (fig-forth-auto680):01240 ENCLOS FDB *+NATWID
1244+14FF A641 (fig-forth-auto680):01241 LDA 1,U ; Delimiter character to match against in A.
1245+1501 AE42 (fig-forth-auto680):01242 LDX NATWID,U ; Buffer to scan in.
1246+1503 5F (fig-forth-auto680):01243 CLRB ; Initialize offset. (Buffer < 256 wide!)
1247+ (fig-forth-auto680):01244 * Scan to a non-delimiter or a NUL
1248+1504 6D85 (fig-forth-auto680):01245 ENCDEL TST B,X ; NUL ?
1249+1506 271F (fig-forth-auto680):01246 BEQ ENCNUL
1250+1508 A185 (fig-forth-auto680):01247 CMPA B,X ; Delimiter?
1251+150A 2603 (fig-forth-auto680):01248 BNE ENC1ST
1252+150C 5C (fig-forth-auto680):01249 INCB ; count character
1253+150D 20F5 (fig-forth-auto680):01250 BRA ENCDEL
1254+ (fig-forth-auto680):01251 * Found first character. Save the offset.
1255+150F E741 (fig-forth-auto680):01252 ENC1ST STB 1,U ; Found first non-delimiter character --
1256+1511 6FC4 (fig-forth-auto680):01253 CLR ,U ; store the count, zero high byte.
1257+ (fig-forth-auto680):01254 * Scan to a delimiter or a NUL
1258+1513 6D85 (fig-forth-auto680):01255 ENCSYM TST B,X ; NUL ?
1259+1515 271E (fig-forth-auto680):01256 BEQ ENC0TR
1260+1517 A185 (fig-forth-auto680):01257 CMPA B,X ; delimiter?
1261+1519 2703 (fig-forth-auto680):01258 BEQ ENCEND
1262+151B 5C (fig-forth-auto680):01259 INCB
1263+151C 20F5 (fig-forth-auto680):01260 BRA ENCSYM
1264+ (fig-forth-auto680):01261 * Found end of symbol. Push offset to delimiter found.
1265+151E 4F (fig-forth-auto680):01262 ENCEND CLRA ; high byte -- buffer < 255 wide!
1266+151F 3606 (fig-forth-auto680):01263 PSHU A,B ; Offset to seen delimiter.
1267+ (fig-forth-auto680):01264 * Advance and push address of next character to check.
1268+1521 C30001 (fig-forth-auto680):01265 ADDD #1 ; In case offset was 255.
1269+1524 3606 (fig-forth-auto680):01266 PSHU A,B
1270+1526 39 (fig-forth-auto680):01267 RTS
1271+ (fig-forth-auto680):01268 * Found NUL before non-delimiter, therefore there is no word
1272+1527 4F (fig-forth-auto680):01269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
1273+1528 EDC4 (fig-forth-auto680):01270 STD ,U ; offset to NUL.
1274+152A C30001 (fig-forth-auto680):01271 ADDD #1 ; Point after NUL to allow (FIND) to match it.
1275+152D 3606 (fig-forth-auto680):01272 PSHU A,B ;
1276+152F 830001 (fig-forth-auto680):01273 SUBD #1 ; Next is not passed NUL.
1277+1532 3606 (fig-forth-auto680):01274 PSHU A,B ; Stealing code will save only one byte.
1278+1534 39 (fig-forth-auto680):01275 RTS
1279+ (fig-forth-auto680):01276 * Found NUL following the word instead of delimiter.
1280+1535 (fig-forth-auto680):01277 ENC0TR
1281+ (fig-forth-auto680):01278 * INC <TRACEM
1282+ (fig-forth-auto680):01279 * LBSR DBGREG
1283+1535 4F (fig-forth-auto680):01280 CLRA
1284+1536 3606 (fig-forth-auto680):01281 PSHU A,B ; Save offset to first after symbol (NUL)
1285+ (fig-forth-auto680):01282 * LBSR DBGREG
1286+1538 3606 (fig-forth-auto680):01283 PSHU A,B ; and count scanned.
1287+ (fig-forth-auto680):01284 * LBSR DBGREG
1288+ (fig-forth-auto680):01285 * DEC <TRACEM
1289+153A 39 (fig-forth-auto680):01286 RTS
1290+ (fig-forth-auto680):01287 * NOTE :
1291+ (fig-forth-auto680):01288 * FC means offset (bytes) to First Character of next word
1292+ (fig-forth-auto680):01289 * EW " " to End of Word
1293+ (fig-forth-auto680):01290 * NC " " to Next Character to start next enclose at
1294+ (fig-forth-auto680):01291 * ENCLOS FDB *+NATWID
1295+ (fig-forth-auto680):01292 * LEAS 1,S ;
1296+ (fig-forth-auto680):01293 * PULS B ; now, get the low byte, for an 8-bit delimiter
1297+ (fig-forth-auto680):01294 * TFR S,X ; TSX :
1298+ (fig-forth-auto680):01295 * LDX 0,X
1299+ (fig-forth-auto680):01296 * CLR N
1300+ (fig-forth-auto680):01297 * * wait for a non-delimiter or a NUL
1301+ (fig-forth-auto680):01298 * ENCDEL LDA 0,X
1302+ (fig-forth-auto680):01299 * BEQ ENCNUL
1303+ (fig-forth-auto680):01300 * PSHS B ; ** emulating CBA:
1304+ (fig-forth-auto680):01301 * CMPA ,S+ ; CHECK FOR DELIM
1305+ (fig-forth-auto680):01302 * BNE ENC1ST
1306+ (fig-forth-auto680):01303 * LEAX 1,X ;
1307+ (fig-forth-auto680):01304 * INC N
1308+ (fig-forth-auto680):01305 * BRA ENCDEL
1309+ (fig-forth-auto680):01306 * * found first character. Push FC
1310+ (fig-forth-auto680):01307 * ENC1ST LDA N found first char.
1311+ (fig-forth-auto680):01308 * PSHS A ;
1312+ (fig-forth-auto680):01309 * CLRA ;
1313+ (fig-forth-auto680):01310 * PSHS A ;
1314+ (fig-forth-auto680):01311 * wait for a delimiter or a NUL
1315+ (fig-forth-auto680):01312 * ENCSYM LDA 0,X
1316+ (fig-forth-auto680):01313 * BEQ ENC0TR
1317+ (fig-forth-auto680):01314 * PSHS B ; ** emulating CBA:
1318+ (fig-forth-auto680):01315 * CMPA ,S+ ; ckech for delim.
1319+ (fig-forth-auto680):01316 * BEQ ENCEND
1320+ (fig-forth-auto680):01317 * LEAX 1,X ;
1321+ (fig-forth-auto680):01318 * INC N
1322+ (fig-forth-auto680):01319 * BRA ENCSYM
1323+ (fig-forth-auto680):01320 * * found EW. Push it
1324+ (fig-forth-auto680):01321 * ENCEND LDB N
1325+ (fig-forth-auto680):01322 * CLRA ;
1326+ (fig-forth-auto680):01323 * PSHS B ;
1327+ (fig-forth-auto680):01324 * PSHS A ;
1328+ (fig-forth-auto680):01325 * * advance and push NC
1329+ (fig-forth-auto680):01326 * INCB ;
1330+ (fig-forth-auto680):01327 * JMP PUSHBA
1331+ (fig-forth-auto680):01328 * found NUL before non-delimiter, therefore there is no word
1332+ (fig-forth-auto680):01329 * ENCNUL LDB N found NUL
1333+ (fig-forth-auto680):01330 * PSHS B ;
1334+ (fig-forth-auto680):01331 * PSHS A ;
1335+ (fig-forth-auto680):01332 * INCB ;
1336+ (fig-forth-auto680):01333 * BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
1337+ (fig-forth-auto680):01334 * ******** Should use labels in case opcodes change! ********
1338+ (fig-forth-auto680):01335 * found NUL following the word instead of SPACE
1339+ (fig-forth-auto680):01336 * ENC0TR LDB N
1340+ (fig-forth-auto680):01337 * PSHS B ; save EW
1341+ (fig-forth-auto680):01338 * PSHS A ;
1342+ (fig-forth-auto680):01339 * ENCL8 LDB N save NC
1343+ (fig-forth-auto680):01340 * JMP PUSHBA
1344+ (fig-forth-auto680):01341
1345+ (fig-forth-auto680):01342 PAGE
1346+ (fig-forth-auto680):01343 *
1347+ (fig-forth-auto680):01344 * ######>> screen 21 <<
1348+ (fig-forth-auto680):01345 * The next 4 words call system dependant I/O routines
1349+ (fig-forth-auto680):01346 * which are listed after word "-->" ( lable: "arrow" )
1350+ (fig-forth-auto680):01347 * in the dictionary.
1351+ (fig-forth-auto680):01348 *
1352+ (fig-forth-auto680):01349 * ======>> 13 <<
1353+ (fig-forth-auto680):01350 * ( c --- )
1354+ (fig-forth-auto680):01351 * Write c to the output device (screen or printer).
1355+ (fig-forth-auto680):01352 * ROM Uses the ECB device number at address $6F,
1356+ (fig-forth-auto680):01353 * -2 is printer, 0 is screen.
1357+153B 84 (fig-forth-auto680):01354 FCB $84
1358+153C 454D49 (fig-forth-auto680):01355 FCC 'EMI' ; 'EMIT'
1359+153F D4 (fig-forth-auto680):01356 FCB $D4
1360+1540 14F3 (fig-forth-auto680):01357 FDB ENCLOS-10
1361+1542 1544 (fig-forth-auto680):01358 EMIT FDB *+NATWID
1362+1544 3706 (fig-forth-auto680):01359 PULU D
1363+1546 171067 (fig-forth-auto680):01360 LBSR PEMIT ; PEMIT expects the character in D.
1364+1549 0C33 (fig-forth-auto680):01361 INC <XOUT+1
1365+154B 2602 (fig-forth-auto680):01362 BNE EMITDN
1366+154D 0C32 (fig-forth-auto680):01363 INC <XOUT
1367+154F 39 (fig-forth-auto680):01364 EMITDN RTS
1368+ (fig-forth-auto680):01365 * PULS A ;
1369+ (fig-forth-auto680):01366 * PULS A ;
1370+ (fig-forth-auto680):01367 * JSR PEMIT
1371+ (fig-forth-auto680):01368 * LDX UP
1372+ (fig-forth-auto680):01369 * INC XOUT+1-UORIG,X
1373+ (fig-forth-auto680):01370 * BNE *+4 ;
1374+ (fig-forth-auto680):01371 * ****WARNING**** HARD OFFSET: *+4 ****
1375+ (fig-forth-auto680):01372 * INC XOUT-UORIG,X
1376+ (fig-forth-auto680):01373 * JMP NEXT
1377+ (fig-forth-auto680):01374 *
1378+ (fig-forth-auto680):01375 * ======>> 14 <<
1379+ (fig-forth-auto680):01376 * ( --- c )
1380+ (fig-forth-auto680):01377 * ( --- BREAK )
1381+ (fig-forth-auto680):01378 * Wait for a key from the keyboard.
1382+ (fig-forth-auto680):01379 * If the key is BREAK, set the high byte (result $FF03).
1383+1550 83 (fig-forth-auto680):01380 FCB $83
1384+1551 4B45 (fig-forth-auto680):01381 FCC 'KE' ; 'KEY'
1385+1553 D9 (fig-forth-auto680):01382 FCB $D9
1386+1554 153B (fig-forth-auto680):01383 FDB EMIT-7
1387+1556 1558 (fig-forth-auto680):01384 KEY FDB *+NATWID
1388+1558 171062 (fig-forth-auto680):01385 LBSR PKEY ; PKEY leaves the key/break code in D.
1389+155B 3606 (fig-forth-auto680):01386 PSHU D
1390+155D 39 (fig-forth-auto680):01387 RTS
1391+ (fig-forth-auto680):01388 * JSR PKEY
1392+ (fig-forth-auto680):01389 * PSHS A ;
1393+ (fig-forth-auto680):01390 * CLRA ;
1394+ (fig-forth-auto680):01391 * PSHS A ;
1395+ (fig-forth-auto680):01392 * JMP NEXT
1396+ (fig-forth-auto680):01393 *
1397+ (fig-forth-auto680):01394 * ======>> 15 <<
1398+ (fig-forth-auto680):01395 * ( --- f )
1399+ (fig-forth-auto680):01396 * Scan keyboard, but do not wait.
1400+ (fig-forth-auto680):01397 * Return 0 if no key,
1401+ (fig-forth-auto680):01398 * BREAK ($ff03) if BREAK is pressed,
1402+ (fig-forth-auto680):01399 * or key currently pressed.
1403+155E 89 (fig-forth-auto680):01400 FCB $89
1404+155F 3F5445524D494E41 (fig-forth-auto680):01401 FCC '?TERMINA' ; '?TERMINAL'
1405+1567 CC (fig-forth-auto680):01402 FCB $CC
1406+1568 1550 (fig-forth-auto680):01403 FDB KEY-6
1407+156A 156C (fig-forth-auto680):01404 QTERM FDB *+NATWID
1408+156C 171073 (fig-forth-auto680):01405 LBSR PQTER ; PQTER leaves the flag/key in D.
1409+156F 3606 (fig-forth-auto680):01406 PSHU D
1410+1571 39 (fig-forth-auto680):01407 RTS
1411+ (fig-forth-auto680):01408 * JSR PQTER
1412+ (fig-forth-auto680):01409 * CLRB ;
1413+ (fig-forth-auto680):01410 * JMP PUSHBA stack the flag
1414+ (fig-forth-auto680):01411 *
1415+ (fig-forth-auto680):01412 * ======>> 16 <<
1416+ (fig-forth-auto680):01413 * ( --- )
1417+ (fig-forth-auto680):01414 * EMIT a Carriage Return (ASCII CR).
1418+1572 82 (fig-forth-auto680):01415 FCB $82
1419+1573 43 (fig-forth-auto680):01416 FCC 'C' ; 'CR'
1420+1574 D2 (fig-forth-auto680):01417 FCB $D2
1421+1575 155E (fig-forth-auto680):01418 FDB QTERM-12
1422+1577 1579 (fig-forth-auto680):01419 CR FDB *+NATWID
1423+1579 161071 (fig-forth-auto680):01420 LBRA PCR ; Nothing really to do here.
1424+ (fig-forth-auto680):01421 * JSR PCR
1425+ (fig-forth-auto680):01422 * JMP NEXT
1426+ (fig-forth-auto680):01423 *
1427+ (fig-forth-auto680):01424 * ######>> screen 22 <<
1428+ (fig-forth-auto680):01425 * ======>> 17 <<
1429+ (fig-forth-auto680):01426 * ( source target count --- )
1430+ (fig-forth-auto680):01427 * Copy/move count bytes from source to target.
1431+ (fig-forth-auto680):01428 * Moves ascending addresses,
1432+ (fig-forth-auto680):01429 * so that overlapping only works if the source is above the destination.
1433+157C 85 (fig-forth-auto680):01430 FCB $85
1434+157D 434D4F56 (fig-forth-auto680):01431 FCC 'CMOV' ; 'CMOVE' : source, destination, count
1435+1581 C5 (fig-forth-auto680):01432 FCB $C5
1436+1582 1572 (fig-forth-auto680):01433 FDB CR-5
1437+1584 1586 (fig-forth-auto680):01434 CMOVE FDB *+NATWID
1438+1586 3420 (fig-forth-auto680):01435 PSHS Y ;
1439+ (fig-forth-auto680):01436 * INC <TRACEM
1440+ (fig-forth-auto680):01437 * LBSR DBGREG
1441+1588 AE42 (fig-forth-auto680):01438 LDX 1*NATWID,U
1442+158A 10AE44 (fig-forth-auto680):01439 LDY 2*NATWID,U
1443+158D 2004 (fig-forth-auto680):01440 BRA CMOVLE ;
1444+158F (fig-forth-auto680):01441 CMOVLP
1445+ (fig-forth-auto680):01442 * LBSR DBGREG
1446+158F A6A0 (fig-forth-auto680):01443 LDA ,Y+
1447+1591 A780 (fig-forth-auto680):01444 STA ,X+
1448+ (fig-forth-auto680):01445 * LBSR DBGREG
1449+1593 (fig-forth-auto680):01446 CMOVLE
1450+1593 ECC4 (fig-forth-auto680):01447 LDD ,U
1451+1595 830001 (fig-forth-auto680):01448 SUBD #1
1452+1598 EDC4 (fig-forth-auto680):01449 STD ,U
1453+159A 24F3 (fig-forth-auto680):01450 BCC CMOVLP
1454+159C 3346 (fig-forth-auto680):01451 LEAU 3*NATWID,U
1455+ (fig-forth-auto680):01452 * DEC <TRACEM
1456+159E 35A0 (fig-forth-auto680):01453 PULS Y,PC
1457+ (fig-forth-auto680):01454 * One way: ; takes ( 37+17*count+9*(count/256) cycles )
1458+ (fig-forth-auto680):01455 * PSHS Y ; #2~7 ; Gotta have our pointers.
1459+ (fig-forth-auto680):01456 * INC <TRACEM
1460+ (fig-forth-auto680):01457 * LBSR DBGREG
1461+ (fig-forth-auto680):01458 * PULU D,X,Y ; #2~11
1462+ (fig-forth-auto680):01459 * PSHS A ; #2~6 ; Gotta have our pointers.
1463+ (fig-forth-auto680):01460 * BRA CMOVLE ; #2~3
1464+ (fig-forth-auto680):01461 * CMOVLP
1465+ (fig-forth-auto680):01462 * LBSR DBGREG
1466+ (fig-forth-auto680):01463 * LDA ,Y+ ; #2~6
1467+ (fig-forth-auto680):01464 * STA ,X+ ; #2~6
1468+ (fig-forth-auto680):01465 * LBSR DBGREG
1469+ (fig-forth-auto680):01466 * CMOVLE
1470+ (fig-forth-auto680):01467 * SUBB #1 ; #2~2
1471+ (fig-forth-auto680):01468 * BCC CMOVLP ; #2~3
1472+ (fig-forth-auto680):01469 * DEC ,S ; #2=6
1473+ (fig-forth-auto680):01470 * BPL CMOVLP ; #2~3
1474+ (fig-forth-auto680):01471 * DEC <TRACEM
1475+ (fig-forth-auto680):01472 * PULS A,Y,PC ; #2~10
1476+ (fig-forth-auto680):01473 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
1477+ (fig-forth-auto680):01474 * LDD #0 ; #3~3
1478+ (fig-forth-auto680):01475 * SUBD ,U++ ; #2~9 ; invert the count
1479+ (fig-forth-auto680):01476 * PSHS A,Y ; #2~8
1480+ (fig-forth-auto680):01477 * PULU X,Y ; #2~9
1481+ (fig-forth-auto680):01478 * BEQ CMOVEX ; #2~3
1482+ (fig-forth-auto680):01479 * CMOVEL
1483+ (fig-forth-auto680):01480 * LDA ,Y+ ; #2~6
1484+ (fig-forth-auto680):01481 * STA ,X+ ; #2~6
1485+ (fig-forth-auto680):01482 * INCB ; #1~2
1486+ (fig-forth-auto680):01483 * BNE CMOVEL ; #2~3
1487+ (fig-forth-auto680):01484 * INC ,S ; #2~6
1488+ (fig-forth-auto680):01485 * BNE CMOVEL ; #2~3
1489+ (fig-forth-auto680):01486 * CMOVEX
1490+ (fig-forth-auto680):01487 * PULS A,Y,PC ; #2~10
1491+ (fig-forth-auto680):01488 * Yet another way ; takes ( 37+29*count cycles )
1492+ (fig-forth-auto680):01489 * PSHS Y ; #2~7
1493+ (fig-forth-auto680):01490 * LDX NATWID,U ; #2~6
1494+ (fig-forth-auto680):01491 * LDY NATWID,U ; #3~7
1495+ (fig-forth-auto680):01492 * BRA CMOVLE ; #2~3
1496+ (fig-forth-auto680):01493 * CMOVLP
1497+ (fig-forth-auto680):01494 * LDA ,Y+ ; #2~6
1498+ (fig-forth-auto680):01495 * STA ,X+ ; #2~6
1499+ (fig-forth-auto680):01496 * CMOVLE
1500+ (fig-forth-auto680):01497 * LDD ,U ; #2~5
1501+ (fig-forth-auto680):01498 * SUBD #1 ; #3~4
1502+ (fig-forth-auto680):01499 * STD ,U ; #2~5
1503+ (fig-forth-auto680):01500 * BPL CMOVLP ; #2~3
1504+ (fig-forth-auto680):01501 * LEAU 3*NATWID,U ; #2~5
1505+ (fig-forth-auto680):01502 * PULS Y,PC ; #2~9
1506+ (fig-forth-auto680):01503 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
1507+ (fig-forth-auto680):01504 * PSHS Y ; #2~7
1508+ (fig-forth-auto680):01505 * LDX NATWID,U ; #2~6
1509+ (fig-forth-auto680):01506 * LDY 2*NATWID,U ; #3~7
1510+ (fig-forth-auto680):01507 * LDD ,U ; #2~5
1511+ (fig-forth-auto680):01508 * BITB #1 ; #2~2
1512+ (fig-forth-auto680):01509 * BEQ CMOVLE ; #2~3
1513+ (fig-forth-auto680):01510 * SUBD #1 ; #3~4
1514+ (fig-forth-auto680):01511 * STD ,U ; #2~5
1515+ (fig-forth-auto680):01512 * LDA ,Y+ ; #2~6
1516+ (fig-forth-auto680):01513 * STA ,X+ ; #2~6
1517+ (fig-forth-auto680):01514 * BRA CMOVLE ; #2~3
1518+ (fig-forth-auto680):01515 * CMOVLP
1519+ (fig-forth-auto680):01516 * LDD ,Y++ ; #2~8
1520+ (fig-forth-auto680):01517 * STD ,X++ ; #2~8
1521+ (fig-forth-auto680):01518 * CMOVLI
1522+ (fig-forth-auto680):01519 * LDD ,U ; #2~5
1523+ (fig-forth-auto680):01520 * CMOVLE
1524+ (fig-forth-auto680):01521 * SUBD #2 ; #3~4
1525+ (fig-forth-auto680):01522 * STD ,U ; #2~5
1526+ (fig-forth-auto680):01523 * BPL CMOVLP ; #2~3
1527+ (fig-forth-auto680):01524 * LEAU 3*NATWID,U ; #2~5
1528+ (fig-forth-auto680):01525 * PULS Y,PC ; #2~9
1529+ (fig-forth-auto680):01526 * From the 6800 model:
1530+ (fig-forth-auto680):01527 * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
1531+ (fig-forth-auto680):01528 * LDX #N
1532+ (fig-forth-auto680):01529 * LDB #6
1533+ (fig-forth-auto680):01530 * CMOV1 PULS A ;
1534+ (fig-forth-auto680):01531 * STA 0,X move parameters to scratch area
1535+ (fig-forth-auto680):01532 * LEAX 1,X ;
1536+ (fig-forth-auto680):01533 * DECB ;
1537+ (fig-forth-auto680):01534 * BNE CMOV1
1538+ (fig-forth-auto680):01535 * CMOV2 LDA N
1539+ (fig-forth-auto680):01536 * LDB N+1
1540+ (fig-forth-auto680):01537 * SUBB #1
1541+ (fig-forth-auto680):01538 * SBCA #0
1542+ (fig-forth-auto680):01539 * STA N
1543+ (fig-forth-auto680):01540 * STB N+1
1544+ (fig-forth-auto680):01541 * BCS CMOV3
1545+ (fig-forth-auto680):01542 * LDX N+4
1546+ (fig-forth-auto680):01543 * LDA 0,X
1547+ (fig-forth-auto680):01544 * LEAX 1,X ;
1548+ (fig-forth-auto680):01545 * STX N+4
1549+ (fig-forth-auto680):01546 * LDX N+2
1550+ (fig-forth-auto680):01547 * STA 0,X
1551+ (fig-forth-auto680):01548 * LEAX 1,X ;
1552+ (fig-forth-auto680):01549 * STX N+2
1553+ (fig-forth-auto680):01550 * BRA CMOV2
1554+ (fig-forth-auto680):01551 * CMOV3 JMP NEXT
1555+ (fig-forth-auto680):01552 *
1556+ (fig-forth-auto680):01553 * ######>> screen 23 <<
1557+ (fig-forth-auto680):01554 * ======>> 18 <<
1558+ (fig-forth-auto680):01555 * ( u1 u2 --- ud )
1559+ (fig-forth-auto680):01556 * Multiplies the top two unsigned integers,
1560+ (fig-forth-auto680):01557 * yielding a double integer product.
1561+15A0 82 (fig-forth-auto680):01558 FCB $82
1562+15A1 55 (fig-forth-auto680):01559 FCC 'U' ; 'U*'
1563+15A2 AA (fig-forth-auto680):01560 FCB $AA
1564+15A3 157C (fig-forth-auto680):01561 FDB CMOVE-8
1565+15A5 15A7 (fig-forth-auto680):01562 USTAR FDB *+NATWID
1566+15A7 335C (fig-forth-auto680):01563 LEAU -2*NATWID,U
1567+15A9 A645 (fig-forth-auto680):01564 LDA 2*NATWID+1,U ; least
1568+15AB E647 (fig-forth-auto680):01565 LDB 3*NATWID+1,U
1569+15AD 3D (fig-forth-auto680):01566 MUL
1570+15AE ED42 (fig-forth-auto680):01567 STD NATWID,U
1571+15B0 A644 (fig-forth-auto680):01568 LDA 2*NATWID,U ; most
1572+15B2 E646 (fig-forth-auto680):01569 LDB 3*NATWID,U
1573+15B4 3D (fig-forth-auto680):01570 MUL
1574+15B5 EDC4 (fig-forth-auto680):01571 STD ,U
1575+15B7 EC45 (fig-forth-auto680):01572 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
1576+15B9 3D (fig-forth-auto680):01573 MUL
1577+15BA E341 (fig-forth-auto680):01574 ADDD 1,U
1578+15BC 2402 (fig-forth-auto680):01575 BCC USTAR3
1579+15BE 6CC4 (fig-forth-auto680):01576 INC ,U
1580+15C0 ED41 (fig-forth-auto680):01577 USTAR3 STD 1,U
1581+15C2 A644 (fig-forth-auto680):01578 LDA 2*NATWID,U ; second inner (u2 hi)
1582+15C4 E646 (fig-forth-auto680):01579 LDB 3*NATWID,U ; (u1 lo)
1583+15C6 3D (fig-forth-auto680):01580 MUL
1584+15C7 E341 (fig-forth-auto680):01581 ADDD 1,U
1585+15C9 2402 (fig-forth-auto680):01582 BCC USTAR4
1586+15CB 6CC4 (fig-forth-auto680):01583 INC ,U
1587+15CD ED41 (fig-forth-auto680):01584 USTAR4 STD 1,U
1588+15CF 3716 (fig-forth-auto680):01585 PULU D,X
1589+15D1 EDC4 (fig-forth-auto680):01586 STD ,U
1590+15D3 AF42 (fig-forth-auto680):01587 STX NATWID,U
1591+15D5 39 (fig-forth-auto680):01588 RTS
1592+ (fig-forth-auto680):01589 *
1593+ (fig-forth-auto680):01590 * from 6800 model:
1594+ (fig-forth-auto680):01591 * BSR USTARS
1595+ (fig-forth-auto680):01592 * LEAS 1,S ;
1596+ (fig-forth-auto680):01593 * LEAS 1,S ;
1597+ (fig-forth-auto680):01594 * JMP PUSHBA
1598+ (fig-forth-auto680):01595 *
1599+ (fig-forth-auto680):01596 * The following is a subroutine which
1600+ (fig-forth-auto680):01597 * multiplies top 2 words on stack,
1601+ (fig-forth-auto680):01598 * leaving 32-bit result: high order word in A,B
1602+ (fig-forth-auto680):01599 * low order word in 2nd word of stack.
1603+ (fig-forth-auto680):01600 *
1604+ (fig-forth-auto680):01601 * USTARS LDA #16 bits/word counter
1605+ (fig-forth-auto680):01602 * PSHS A ;
1606+ (fig-forth-auto680):01603 * CLRA ;
1607+ (fig-forth-auto680):01604 * CLRB ;
1608+ (fig-forth-auto680):01605 * TFR S,X ; TSX :
1609+ (fig-forth-auto680):01606 * USTAR2 ROR 5,X shift multiplier
1610+ (fig-forth-auto680):01607 * ROR 6,X
1611+ (fig-forth-auto680):01608 * DEC 0,X done?
1612+ (fig-forth-auto680):01609 * BMI USTAR4
1613+ (fig-forth-auto680):01610 * BCC USTAR3
1614+ (fig-forth-auto680):01611 * ADDB 4,X
1615+ (fig-forth-auto680):01612 * ADCA 3,X
1616+ (fig-forth-auto680):01613 * USTAR3 RORA ;
1617+ (fig-forth-auto680):01614 * RORB ; shift result
1618+ (fig-forth-auto680):01615 * BRA USTAR2
1619+ (fig-forth-auto680):01616 * USTAR4 LEAS 1,S ; dump counter
1620+ (fig-forth-auto680):01617 * RTS
1621+ (fig-forth-auto680):01618 *
1622+ (fig-forth-auto680):01619 * ######>> screen 24 <<
1623+ (fig-forth-auto680):01620 * ======>> 19 <<
1624+ (fig-forth-auto680):01621 * ( ud u --- uremainder uquotient )
1625+ (fig-forth-auto680):01622 * Divides the top unsigned integer
1626+ (fig-forth-auto680):01623 * into the second and third words on the stack
1627+ (fig-forth-auto680):01624 * as a single unsigned double integer,
1628+ (fig-forth-auto680):01625 * leaving the remainder and quotient (quotient on top)
1629+ (fig-forth-auto680):01626 * as unsigned integers.
1630+ (fig-forth-auto680):01627 *
1631+ (fig-forth-auto680):01628 * The smaller the divisor, the more likely dropping the high word
1632+ (fig-forth-auto680):01629 * of the quotient loses significant bits. See M/MOD .
1633+ (fig-forth-auto680):01630 *
1634+15D6 82 (fig-forth-auto680):01631 FCB $82
1635+15D7 55 (fig-forth-auto680):01632 FCC 'U' ; 'U/'
1636+15D8 AF (fig-forth-auto680):01633 FCB $AF
1637+15D9 15A0 (fig-forth-auto680):01634 FDB USTAR-5
1638+15DB 15DD (fig-forth-auto680):01635 USLASH FDB *+NATWID
1639+15DD 8611 (fig-forth-auto680):01636 LDA #17 ; bit ct
1640+15DF 3402 (fig-forth-auto680):01637 PSHS A
1641+15E1 EC42 (fig-forth-auto680):01638 LDD NATWID,U ; dividend
1642+15E3 10A3C4 (fig-forth-auto680):01639 USLDIV CMPD ,U ; divisor
1643+15E6 2404 (fig-forth-auto680):01640 BHS USLSUB
1644+15E8 1CFE (fig-forth-auto680):01641 ANDCC #~1 ; carry clear
1645+15EA 2004 (fig-forth-auto680):01642 BRA USLBIT
1646+15EC A3C4 (fig-forth-auto680):01643 USLSUB SUBD ,U
1647+15EE 1A01 (fig-forth-auto680):01644 ORCC #1 ; quotient, (carry set)
1648+15F0 6945 (fig-forth-auto680):01645 USLBIT ROL 2*NATWID+1,U ; save it
1649+15F2 6944 (fig-forth-auto680):01646 ROL 2*NATWID,U
1650+15F4 6AE4 (fig-forth-auto680):01647 DEC ,S ; more bits?
1651+15F6 2706 (fig-forth-auto680):01648 BEQ USLR
1652+15F8 59 (fig-forth-auto680):01649 ROLB ; remainder
1653+15F9 49 (fig-forth-auto680):01650 ROLA
1654+15FA 24E7 (fig-forth-auto680):01651 BCC USLDIV
1655+15FC 20EE (fig-forth-auto680):01652 BRA USLSUB
1656+15FE 3342 (fig-forth-auto680):01653 USLR LEAU NATWID,U
1657+1600 AE42 (fig-forth-auto680):01654 LDX NATWID,U
1658+1602 ED42 (fig-forth-auto680):01655 STD NATWID,U
1659+1604 AFC4 (fig-forth-auto680):01656 STX ,U
1660+1606 3582 (fig-forth-auto680):01657 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
1661+ (fig-forth-auto680):01658 *
1662+ (fig-forth-auto680):01659 * from 6800 model:
1663+ (fig-forth-auto680):01660 * LDA #17
1664+ (fig-forth-auto680):01661 * PSHS A ;
1665+ (fig-forth-auto680):01662 * TFR S,X ; TSX :
1666+ (fig-forth-auto680):01663 * LDA 3,X
1667+ (fig-forth-auto680):01664 * LDB 4,X
1668+ (fig-forth-auto680):01665 * USL1 CMPA 1,X
1669+ (fig-forth-auto680):01666 * BHI USL3
1670+ (fig-forth-auto680):01667 * BCS USL2
1671+ (fig-forth-auto680):01668 * CMPB 2,X
1672+ (fig-forth-auto680):01669 * BCC USL3
1673+ (fig-forth-auto680):01670 * USL2 ANDCC #~$01 ; CLC :
1674+ (fig-forth-auto680):01671 * BRA USL4
1675+ (fig-forth-auto680):01672 * USL3 SUBB 2,X
1676+ (fig-forth-auto680):01673 * SBCA 1,X
1677+ (fig-forth-auto680):01674 * ORCC #$01 ; SEC :
1678+ (fig-forth-auto680):01675 * USL4 ROL 6,X
1679+ (fig-forth-auto680):01676 * ROL 5,X
1680+ (fig-forth-auto680):01677 * DEC 0,X
1681+ (fig-forth-auto680):01678 * BEQ USL5
1682+ (fig-forth-auto680):01679 * ROLB ;
1683+ (fig-forth-auto680):01680 * ROLA ;
1684+ (fig-forth-auto680):01681 * BCC USL1
1685+ (fig-forth-auto680):01682 * BRA USL3
1686+ (fig-forth-auto680):01683 * USL5 LEAS 1,S ;
1687+ (fig-forth-auto680):01684 * LEAS 1,S ;
1688+ (fig-forth-auto680):01685 * LEAS 1,S ;
1689+ (fig-forth-auto680):01686 * LEAS 1,S ;
1690+ (fig-forth-auto680):01687 * LEAS 1,S ;
1691+ (fig-forth-auto680):01688 * JMP SWAP+4 reverse quotient & remainder
1692+ (fig-forth-auto680):01689 *
1693+ (fig-forth-auto680):01690 * ######>> screen 25 <<
1694+ (fig-forth-auto680):01691 * ======>> 20 <<
1695+ (fig-forth-auto680):01692 * ( n1 n2 --- n )
1696+ (fig-forth-auto680):01693 * Bitwise and the top two integers.
1697+1608 83 (fig-forth-auto680):01694 FCB $83
1698+1609 414E (fig-forth-auto680):01695 FCC 'AN' ; 'AND'
1699+160B C4 (fig-forth-auto680):01696 FCB $C4
1700+160C 15D6 (fig-forth-auto680):01697 FDB USLASH-5
1701+160E 1610 (fig-forth-auto680):01698 AND FDB *+NATWID
1702+1610 3706 (fig-forth-auto680):01699 PULU A,B
1703+1612 E441 (fig-forth-auto680):01700 ANDB 1,U
1704+1614 A4C4 (fig-forth-auto680):01701 ANDA ,U
1705+1616 EDC4 (fig-forth-auto680):01702 STD ,U
1706+1618 39 (fig-forth-auto680):01703 RTS
1707+ (fig-forth-auto680):01704 * PULS A ;
1708+ (fig-forth-auto680):01705 * PULS B ;
1709+ (fig-forth-auto680):01706 * TFR S,X ; TSX :
1710+ (fig-forth-auto680):01707 * ANDB 1,X
1711+ (fig-forth-auto680):01708 * ANDA 0,X
1712+ (fig-forth-auto680):01709 * JMP STABX
1713+ (fig-forth-auto680):01710 *
1714+ (fig-forth-auto680):01711 * ======>> 21 <<
1715+ (fig-forth-auto680):01712 * ( n1 n2 --- n )
1716+ (fig-forth-auto680):01713 * Bitwise or the top two integers.
1717+1619 82 (fig-forth-auto680):01714 FCB $82
1718+161A 4F (fig-forth-auto680):01715 FCC 'O' ; 'OR'
1719+161B D2 (fig-forth-auto680):01716 FCB $D2
1720+161C 1608 (fig-forth-auto680):01717 FDB AND-6
1721+161E 1620 (fig-forth-auto680):01718 OR FDB *+NATWID
1722+1620 3706 (fig-forth-auto680):01719 PULU A,B
1723+1622 EA41 (fig-forth-auto680):01720 ORB 1,U
1724+1624 AAC4 (fig-forth-auto680):01721 ORA ,U
1725+1626 EDC4 (fig-forth-auto680):01722 STD ,U
1726+1628 39 (fig-forth-auto680):01723 RTS
1727+ (fig-forth-auto680):01724 * PULS A ;
1728+ (fig-forth-auto680):01725 * PULS B ;
1729+ (fig-forth-auto680):01726 * TFR S,X ; TSX :
1730+ (fig-forth-auto680):01727 * ORB 1,X
1731+ (fig-forth-auto680):01728 * ORA 0,X
1732+ (fig-forth-auto680):01729 * JMP STABX
1733+ (fig-forth-auto680):01730 *
1734+ (fig-forth-auto680):01731 * ======>> 22 <<
1735+ (fig-forth-auto680):01732 * ( n1 n2 --- n )
1736+ (fig-forth-auto680):01733 * Bitwise exclusive or the top two integers.
1737+1629 83 (fig-forth-auto680):01734 FCB $83
1738+162A 584F (fig-forth-auto680):01735 FCC 'XO' ; 'XOR'
1739+162C D2 (fig-forth-auto680):01736 FCB $D2
1740+162D 1619 (fig-forth-auto680):01737 FDB OR-5
1741+162F 1631 (fig-forth-auto680):01738 XOR FDB *+NATWID
1742+1631 3706 (fig-forth-auto680):01739 PULU A,B
1743+1633 E841 (fig-forth-auto680):01740 EORB 1,U
1744+1635 A8C4 (fig-forth-auto680):01741 EORA ,U
1745+1637 EDC4 (fig-forth-auto680):01742 STD ,U
1746+1639 39 (fig-forth-auto680):01743 RTS
1747+ (fig-forth-auto680):01744 * PULS A ;
1748+ (fig-forth-auto680):01745 * PULS B ;
1749+ (fig-forth-auto680):01746 * TFR S,X ; TSX :
1750+ (fig-forth-auto680):01747 * EORB 1,X
1751+ (fig-forth-auto680):01748 * EORA 0,X
1752+ (fig-forth-auto680):01749 * JMP STABX
1753+ (fig-forth-auto680):01750 *
1754+ (fig-forth-auto680):01751 * ######>> screen 26 <<
1755+ (fig-forth-auto680):01752 * ======>> 23 <<
1756+ (fig-forth-auto680):01753 * ( --- adr )
1757+ (fig-forth-auto680):01754 * Fetch the parameter stack pointer (before it is pushed).
1758+ (fig-forth-auto680):01755 * This points at whatever was on the top of stack before.
1759+163A 83 (fig-forth-auto680):01756 FCB $83
1760+163B 5350 (fig-forth-auto680):01757 FCC 'SP' ; 'SP@'
1761+163D C0 (fig-forth-auto680):01758 FCB $C0
1762+163E 1629 (fig-forth-auto680):01759 FDB XOR-6
1763+1640 1642 (fig-forth-auto680):01760 SPAT FDB *+NATWID
1764+1642 1F31 (fig-forth-auto680):01761 TFR U,X
1765+1644 3610 (fig-forth-auto680):01762 PSHU X
1766+1646 39 (fig-forth-auto680):01763 RTS
1767+ (fig-forth-auto680):01764 * TFR S,X ; TSX :
1768+ (fig-forth-auto680):01765 * STX N scratch area
1769+ (fig-forth-auto680):01766 * LDX #N
1770+ (fig-forth-auto680):01767 * JMP GETX
1771+ (fig-forth-auto680):01768 *
1772+ (fig-forth-auto680):01769 * ======>> 24 <<
1773+ (fig-forth-auto680):01770 * ( whatever --- nothing )
1774+ (fig-forth-auto680):01771 * Initialize the parameter stack pointer from the USER variable S0.
1775+ (fig-forth-auto680):01772 * Effectively clears the stack.
1776+1647 83 (fig-forth-auto680):01773 FCB $83
1777+1648 5350 (fig-forth-auto680):01774 FCC 'SP' ; 'SP!'
1778+164A A1 (fig-forth-auto680):01775 FCB $A1
1779+164B 163A (fig-forth-auto680):01776 FDB SPAT-6
1780+164D 164F (fig-forth-auto680):01777 SPSTOR FDB *+NATWID
1781+164F DE1E (fig-forth-auto680):01778 LDU <XSPZER
1782+1651 39 (fig-forth-auto680):01779 RTS
1783+ (fig-forth-auto680):01780 * LDX UP
1784+ (fig-forth-auto680):01781 * LDX XSPZER-UORIG,X
1785+ (fig-forth-auto680):01782 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
1786+ (fig-forth-auto680):01783 * JMP NEXT
1787+ (fig-forth-auto680):01784 * ======>> 25 <<
1788+ (fig-forth-auto680):01785 * ( whatever *** nothing )
1789+ (fig-forth-auto680):01786 * Initialize the return stack pointer from the initialization table
1790+ (fig-forth-auto680):01787 * instead of the user variable R0, for some reason.
1791+ (fig-forth-auto680):01788 * Quite possibly, this should be from R0.
1792+ (fig-forth-auto680):01789 * Effectively aborts all in process definitions, except the active one.
1793+ (fig-forth-auto680):01790 * An emergency measure, to be sure.
1794+ (fig-forth-auto680):01791 * The routine that calls this must never execute a return.
1795+ (fig-forth-auto680):01792 * So this should never be executed from the terminal, I guess.
1796+ (fig-forth-auto680):01793 * This is another that should be compile-time only, and in a separate vocabulary.
1797+1652 83 (fig-forth-auto680):01794 FCB $83
1798+1653 5250 (fig-forth-auto680):01795 FCC 'RP' ; 'RP!'
1799+1655 A1 (fig-forth-auto680):01796 FCB $A1
1800+1656 1647 (fig-forth-auto680):01797 FDB SPSTOR-6
1801+1658 165A (fig-forth-auto680):01798 RPSTOR FDB *+NATWID
1802+165A 3510 (fig-forth-auto680):01799 PULS X ; But this guy has to return to his caller.
1803+165C 10FE1214 (fig-forth-auto680):01800 LDS RINIT
1804+1660 6E84 (fig-forth-auto680):01801 JMP ,X
1805+ (fig-forth-auto680):01802 * LDX RINIT initialize from rom constant
1806+ (fig-forth-auto680):01803 * STX RP
1807+ (fig-forth-auto680):01804 * JMP NEXT
1808+ (fig-forth-auto680):01805 *
1809+ (fig-forth-auto680):01806 * ======>> 26 <<
1810+ (fig-forth-auto680):01807 * ( ip *** )
1811+ (fig-forth-auto680):01808 * Pop IP from return stack (return from high-level definition).
1812+ (fig-forth-auto680):01809 * Can be used in a screen to force interpretion to terminate.
1813+ (fig-forth-auto680):01810 * Must not be executed when temporaries are saved on top of the return stack.
1814+1662 82 (fig-forth-auto680):01811 FCB $82
1815+1663 3B (fig-forth-auto680):01812 FCC ';' ; ';S'
1816+1664 D3 (fig-forth-auto680):01813 FCB $D3
1817+1665 1652 (fig-forth-auto680):01814 FDB RPSTOR-6
1818+1667 1669 (fig-forth-auto680):01815 SEMIS FDB *+NATWID
1819+1669 3526 (fig-forth-auto680):01816 PULS D,Y ; return address in D, and saved IP in Y.
1820+166B 1F05 (fig-forth-auto680):01817 TFR D,PC ; Synthetic return.
1821+ (fig-forth-auto680):01818 *
1822+ (fig-forth-auto680):01819 * Form 6800 model:
1823+ (fig-forth-auto680):01820 * LDX RP
1824+ (fig-forth-auto680):01821 * LEAX 1,X ;
1825+ (fig-forth-auto680):01822 * LEAX 1,X ;
1826+ (fig-forth-auto680):01823 * STX RP
1827+ (fig-forth-auto680):01824 * LDX 0,X get address we have just finished.
1828+ (fig-forth-auto680):01825 * JMP NEXT+2 increment the return address & do next word
1829+ (fig-forth-auto680):01826 *
1830+ (fig-forth-auto680):01827 * ######>> screen 27 <<
1831+ (fig-forth-auto680):01828 * ======>> 27 <<
1832+ (fig-forth-auto680):01829 * ( limit index *** index index )
1833+ (fig-forth-auto680):01830 * Force the terminating condition for the innermost loop by
1834+ (fig-forth-auto680):01831 * copying its index to its limit.
1835+ (fig-forth-auto680):01832 * Termination is postponed until the next
1836+ (fig-forth-auto680):01833 * LOOP or +LOOP instruction is executed.
1837+ (fig-forth-auto680):01834 * The index remains available for use until
1838+ (fig-forth-auto680):01835 * the LOOP or +LOOP instruction is encountered.
1839+ (fig-forth-auto680):01836 * Note that the assumption is that the current count is the correct count
1840+ (fig-forth-auto680):01837 * to end at, rather than pushing the count to the final count.
1841+166D 85 (fig-forth-auto680):01838 FCB $85
1842+166E 4C454156 (fig-forth-auto680):01839 FCC 'LEAV' ; 'LEAVE'
1843+1672 C5 (fig-forth-auto680):01840 FCB $C5
1844+1673 1662 (fig-forth-auto680):01841 FDB SEMIS-5
1845+1675 1677 (fig-forth-auto680):01842 LEAVE FDB *+NATWID
1846+1677 EC62 (fig-forth-auto680):01843 LDD NATWID,S ; Dodge the return address.
1847+1679 ED64 (fig-forth-auto680):01844 STD 2*NATWID,S
1848+167B 39 (fig-forth-auto680):01845 RTS
1849+ (fig-forth-auto680):01846 * LDX RP
1850+ (fig-forth-auto680):01847 * LDA 2,X
1851+ (fig-forth-auto680):01848 * LDB 3,X
1852+ (fig-forth-auto680):01849 * STA 4,X
1853+ (fig-forth-auto680):01850 * STB 5,X
1854+ (fig-forth-auto680):01851 * JMP NEXT
1855+ (fig-forth-auto680):01852 *
1856+ (fig-forth-auto680):01853 * ======>> 28 <<
1857+ (fig-forth-auto680):01854 * ( n --- )
1858+ (fig-forth-auto680):01855 * ( *** n )
1859+ (fig-forth-auto680):01856 * Move top of parameter stack to top of return stack.
1860+167C 82 (fig-forth-auto680):01857 FCB $82
1861+167D 3E (fig-forth-auto680):01858 FCC '>' ; '>R'
1862+167E D2 (fig-forth-auto680):01859 FCB $D2
1863+167F 166D (fig-forth-auto680):01860 FDB LEAVE-8
1864+1681 1683 (fig-forth-auto680):01861 TOR FDB *+NATWID
1865+1683 3706 (fig-forth-auto680):01862 PULU A,B
1866+1685 AEE4 (fig-forth-auto680):01863 LDX ,S
1867+1687 EDE4 (fig-forth-auto680):01864 STD ,S ; Put it where the return address was.
1868+1689 6E84 (fig-forth-auto680):01865 JMP ,X
1869+ (fig-forth-auto680):01866 * LDX RP
1870+ (fig-forth-auto680):01867 * LEAX -1,X ;
1871+ (fig-forth-auto680):01868 * LEAX -1,X ;
1872+ (fig-forth-auto680):01869 * STX RP
1873+ (fig-forth-auto680):01870 * PULS A ;
1874+ (fig-forth-auto680):01871 * PULS B ;
1875+ (fig-forth-auto680):01872 * STA 2,X
1876+ (fig-forth-auto680):01873 * STB 3,X
1877+ (fig-forth-auto680):01874 * JMP NEXT
1878+ (fig-forth-auto680):01875 *
1879+ (fig-forth-auto680):01876 * ======>> 29 <<
1880+ (fig-forth-auto680):01877 * ( --- n )
1881+ (fig-forth-auto680):01878 * ( n *** )
1882+ (fig-forth-auto680):01879 * Move top of return stack to top of parameter stack.
1883+168B 82 (fig-forth-auto680):01880 FCB $82
1884+168C 52 (fig-forth-auto680):01881 FCC 'R' ; 'R>'
1885+168D BE (fig-forth-auto680):01882 FCB $BE
1886+168E 167C (fig-forth-auto680):01883 FDB TOR-5
1887+1690 1692 (fig-forth-auto680):01884 FROMR FDB *+NATWID
1888+1692 3516 (fig-forth-auto680):01885 PULS D,X
1889+1694 3610 (fig-forth-auto680):01886 PSHU X
1890+1696 1F05 (fig-forth-auto680):01887 TFR D,PC
1891+ (fig-forth-auto680):01888 * LDX RP
1892+ (fig-forth-auto680):01889 * LDA 2,X
1893+ (fig-forth-auto680):01890 * LDB 3,X
1894+ (fig-forth-auto680):01891 * LEAX 1,X ;
1895+ (fig-forth-auto680):01892 * LEAX 1,X ;
1896+ (fig-forth-auto680):01893 * STX RP
1897+ (fig-forth-auto680):01894 * JMP PUSHBA
1898+ (fig-forth-auto680):01895 *
1899+ (fig-forth-auto680):01896 * ======>> 30 <<
1900+ (fig-forth-auto680):01897 * ( --- n )
1901+ (fig-forth-auto680):01898 * ( n *** n )
1902+ (fig-forth-auto680):01899 * Copy the top of return stack to top of parameter stack.
1903+ (fig-forth-auto680):01900 * A synonym for I.
1904+1698 81 (fig-forth-auto680):01901 FCB $81 R
1905+1699 D2 (fig-forth-auto680):01902 FCB $D2
1906+169A 168B (fig-forth-auto680):01903 FDB FROMR-5
1907+169C 1467 (fig-forth-auto680):01904 R FDB I+NATWID
1908+ (fig-forth-auto680):01905
1909+ (fig-forth-auto680):01906 * LDX RP
1910+ (fig-forth-auto680):01907 * LEAX 1,X ;
1911+ (fig-forth-auto680):01908 * LEAX 1,X ;
1912+ (fig-forth-auto680):01909 * JMP GETX
1913+ (fig-forth-auto680):01910 *
1914+ (fig-forth-auto680):01911 * ######>> screen 28 <<
1915+ (fig-forth-auto680):01912 * ======>> 31 <<
1916+ (fig-forth-auto680):01913 * ( n --- n=0 )
1917+ (fig-forth-auto680):01914 * Logically invert top of stack;
1918+ (fig-forth-auto680):01915 * or flag true if top is zero, otherwise false.
1919+169E 82 (fig-forth-auto680):01916 FCB $82
1920+169F 30 (fig-forth-auto680):01917 FCC '0' ; '0='
1921+16A0 BD (fig-forth-auto680):01918 FCB $BD
1922+16A1 1698 (fig-forth-auto680):01919 FDB R-4
1923+16A3 16A5 (fig-forth-auto680):01920 ZEQU FDB *+NATWID
1924+16A5 CC0000 (fig-forth-auto680):01921 LDD #0
1925+16A8 AEC4 (fig-forth-auto680):01922 LDX ,U
1926+16AA 2601 (fig-forth-auto680):01923 BNE ZEQUF
1927+16AC 5C (fig-forth-auto680):01924 INCB ; 1 is true
1928+16AD EDC4 (fig-forth-auto680):01925 ZEQUF STD ,U
1929+16AF 39 (fig-forth-auto680):01926 RTS
1930+ (fig-forth-auto680):01927 * TFR S,X ; TSX :
1931+ (fig-forth-auto680):01928 * CLRA ;
1932+ (fig-forth-auto680):01929 * CLRB ;
1933+ (fig-forth-auto680):01930 * LDX 0,X
1934+ (fig-forth-auto680):01931 * BNE ZEQU2
1935+ (fig-forth-auto680):01932 * INCB ;
1936+ (fig-forth-auto680):01933 *ZEQU2 TFR S,X ; TSX :
1937+ (fig-forth-auto680):01934 * JMP STABX
1938+ (fig-forth-auto680):01935 *
1939+ (fig-forth-auto680):01936 * ======>> 32 <<
1940+ (fig-forth-auto680):01937 * ( n --- n<0 )
1941+ (fig-forth-auto680):01938 * Flag true if top is negative (MSbit set), otherwise false.
1942+16B0 82 (fig-forth-auto680):01939 FCB $82
1943+16B1 30 (fig-forth-auto680):01940 FCC '0' ; '0<'
1944+16B2 BC (fig-forth-auto680):01941 FCB $BC
1945+16B3 169E (fig-forth-auto680):01942 FDB ZEQU-5
1946+16B5 16B7 (fig-forth-auto680):01943 ZLESS FDB *+NATWID
1947+16B7 CC0000 (fig-forth-auto680):01944 LDD #0
1948+16BA 6DC4 (fig-forth-auto680):01945 TST ,U
1949+16BC 2A01 (fig-forth-auto680):01946 BPL ZLESSF
1950+16BE 5C (fig-forth-auto680):01947 INCB
1951+16BF EDC4 (fig-forth-auto680):01948 ZLESSF STD ,U
1952+16C1 39 (fig-forth-auto680):01949 RTS
1953+ (fig-forth-auto680):01950 * TFR S,X ; TSX :
1954+ (fig-forth-auto680):01951 * LDA #$80 check the sign bit
1955+ (fig-forth-auto680):01952 * ANDA 0,X
1956+ (fig-forth-auto680):01953 * BEQ ZLESS2
1957+ (fig-forth-auto680):01954 * CLRA ; if neg.
1958+ (fig-forth-auto680):01955 * LDB #1
1959+ (fig-forth-auto680):01956 * JMP STABX
1960+ (fig-forth-auto680):01957 * ZLESS2 CLRB ;
1961+ (fig-forth-auto680):01958 * JMP STABX
1962+ (fig-forth-auto680):01959 *
1963+ (fig-forth-auto680):01960 * ######>> screen 29 <<
1964+ (fig-forth-auto680):01961 * ======>> 33 <<
1965+ (fig-forth-auto680):01962 * ( n1 n2 --- n1+n2 )
1966+ (fig-forth-auto680):01963 * Add top two words.
1967+16C2 81 (fig-forth-auto680):01964 FCB $81 '+'
1968+16C3 AB (fig-forth-auto680):01965 FCB $AB
1969+16C4 16B0 (fig-forth-auto680):01966 FDB ZLESS-5
1970+16C6 16C8 (fig-forth-auto680):01967 PLUS FDB *+NATWID
1971+16C8 3706 (fig-forth-auto680):01968 PULU A,B ; #2~7
1972+16CA E3C4 (fig-forth-auto680):01969 ADDD ,U ; #2~6
1973+16CC EDC4 (fig-forth-auto680):01970 STD ,U ; #2~5
1974+16CE 39 (fig-forth-auto680):01971 RTS ; #1~5 =#7~23
1975+ (fig-forth-auto680):01972 * PULS A ;
1976+ (fig-forth-auto680):01973 * PULS B ;
1977+ (fig-forth-auto680):01974 * TFR S,X ; TSX :
1978+ (fig-forth-auto680):01975 * ADDB 1,X
1979+ (fig-forth-auto680):01976 * ADCA 0,X
1980+ (fig-forth-auto680):01977 * JMP STABX
1981+ (fig-forth-auto680):01978 *
1982+ (fig-forth-auto680):01979 * ======>> 34 <<
1983+ (fig-forth-auto680):01980 * ( d1 d2 --- d1+d2 )
1984+ (fig-forth-auto680):01981 * Add top two double integers.
1985+16CF 82 (fig-forth-auto680):01982 FCB $82
1986+16D0 44 (fig-forth-auto680):01983 FCC 'D' ; 'D+'
1987+16D1 AB (fig-forth-auto680):01984 FCB $AB
1988+16D2 16C2 (fig-forth-auto680):01985 FDB PLUS-4
1989+16D4 16D6 (fig-forth-auto680):01986 DPLUS FDB *+NATWID
1990+16D6 EC46 (fig-forth-auto680):01987 LDD 3*NATWID,U
1991+16D8 E342 (fig-forth-auto680):01988 ADDD NATWID,U
1992+16DA ED46 (fig-forth-auto680):01989 STD 3*NATWID,U
1993+16DC EC44 (fig-forth-auto680):01990 LDD 2*NATWID,U
1994+16DE E941 (fig-forth-auto680):01991 ADCB 1,U
1995+16E0 A9C4 (fig-forth-auto680):01992 ADCA ,U
1996+16E2 3344 (fig-forth-auto680):01993 LEAU 2*NATWID,U
1997+16E4 EDC4 (fig-forth-auto680):01994 STD ,U
1998+16E6 39 (fig-forth-auto680):01995 RTS
1999+ (fig-forth-auto680):01996 * TFR S,X ; TSX :
2000+ (fig-forth-auto680):01997 * ANDCC #~$01 ; CLC :
2001+ (fig-forth-auto680):01998 * LDB #4
2002+ (fig-forth-auto680):01999 * DPLUS2 LDA 3,X
2003+ (fig-forth-auto680):02000 * ADCA 7,X
2004+ (fig-forth-auto680):02001 * STA 7,X
2005+ (fig-forth-auto680):02002 * LEAX -1,X ;
2006+ (fig-forth-auto680):02003 * DECB ;
2007+ (fig-forth-auto680):02004 * BNE DPLUS2
2008+ (fig-forth-auto680):02005 * LEAS 1,S ;
2009+ (fig-forth-auto680):02006 * LEAS 1,S ;
2010+ (fig-forth-auto680):02007 * LEAS 1,S ;
2011+ (fig-forth-auto680):02008 * LEAS 1,S ;
2012+ (fig-forth-auto680):02009 * JMP NEXT
2013+ (fig-forth-auto680):02010 *
2014+ (fig-forth-auto680):02011 * ======>> 35 <<
2015+ (fig-forth-auto680):02012 * ( n --- -n )
2016+ (fig-forth-auto680):02013 * Negate (two's complement) top of stack.
2017+16E7 85 (fig-forth-auto680):02014 FCB $85
2018+16E8 4D494E55 (fig-forth-auto680):02015 FCC 'MINU' ; 'MINUS'
2019+16EC D3 (fig-forth-auto680):02016 FCB $D3
2020+16ED 16CF (fig-forth-auto680):02017 FDB DPLUS-5
2021+16EF 16F1 (fig-forth-auto680):02018 MINUS FDB *+NATWID
2022+16F1 CC0000 (fig-forth-auto680):02019 LDD #0 ; #3~3
2023+16F4 A3C4 (fig-forth-auto680):02020 SUBD ,U ; #2~5
2024+16F6 EDC4 (fig-forth-auto680):02021 STD ,U ; #2~5
2025+16F8 39 (fig-forth-auto680):02022 RTS ; #1~5 = #8~18
2026+ (fig-forth-auto680):02023 *
2027+ (fig-forth-auto680):02024 * from 6800 model code:
2028+ (fig-forth-auto680):02025 * TFR S,X ; TSX :
2029+ (fig-forth-auto680):02026 * NEG 1,X
2030+ (fig-forth-auto680):02027 * BCC MINUS2
2031+ (fig-forth-auto680):02028 * NEG 0,X
2032+ (fig-forth-auto680):02029 * BRA MINUS3
2033+ (fig-forth-auto680):02030 * MINUS2 COM 0,X
2034+ (fig-forth-auto680):02031 * MINUS3 JMP NEXT
2035+ (fig-forth-auto680):02032 *
2036+ (fig-forth-auto680):02033 * ======>> 36 <<
2037+ (fig-forth-auto680):02034 * ( d --- -d )
2038+ (fig-forth-auto680):02035 * Negate (two's complement) top two words on stack as a double integer.
2039+16F9 86 (fig-forth-auto680):02036 FCB $86
2040+16FA 444D494E55 (fig-forth-auto680):02037 FCC 'DMINU' ; 'DMINUS'
2041+16FF D3 (fig-forth-auto680):02038 FCB $D3
2042+1700 16E7 (fig-forth-auto680):02039 FDB MINUS-8
2043+1702 1704 (fig-forth-auto680):02040 DMINUS FDB *+NATWID
2044+1704 CC0000 (fig-forth-auto680):02041 LDD #0 ; #3~3
2045+1707 A342 (fig-forth-auto680):02042 SUBD NATWID,U ; #2~7
2046+1709 ED42 (fig-forth-auto680):02043 STD NATWID,U ; #2~7
2047+170B CC0000 (fig-forth-auto680):02044 LDD #0 ; #3~3
2048+170E E241 (fig-forth-auto680):02045 SBCB 1,U ; #2~5
2049+1710 A2C4 (fig-forth-auto680):02046 SBCA ,U ; #2~4
2050+1712 EDC4 (fig-forth-auto680):02047 STD ,U ; #2~5
2051+1714 39 (fig-forth-auto680):02048 RTS ; #1~5 = #17~39
2052+ (fig-forth-auto680):02049 * TFR S,X ; TSX :
2053+ (fig-forth-auto680):02050 * COM 0,X
2054+ (fig-forth-auto680):02051 * COM 1,X
2055+ (fig-forth-auto680):02052 * COM 2,X
2056+ (fig-forth-auto680):02053 * NEG 3,X
2057+ (fig-forth-auto680):02054 * BNE DMINX
2058+ (fig-forth-auto680):02055 * INC 2,X
2059+ (fig-forth-auto680):02056 * BNE DMINX
2060+ (fig-forth-auto680):02057 * INC 1,X
2061+ (fig-forth-auto680):02058 * BNE DMINX
2062+ (fig-forth-auto680):02059 * INC 0,X
2063+ (fig-forth-auto680):02060 * DMINX JMP NEXT
2064+ (fig-forth-auto680):02061 *
2065+ (fig-forth-auto680):02062 * ######>> screen 30 <<
2066+ (fig-forth-auto680):02063 * ======>> 37 <<
2067+ (fig-forth-auto680):02064 * ( n1 n2 --- n1 n2 n1 )
2068+ (fig-forth-auto680):02065 * Push a copy of the second word on stack.
2069+1715 84 (fig-forth-auto680):02066 FCB $84
2070+1716 4F5645 (fig-forth-auto680):02067 FCC 'OVE' ; 'OVER'
2071+1719 D2 (fig-forth-auto680):02068 FCB $D2
2072+171A 16F9 (fig-forth-auto680):02069 FDB DMINUS-9
2073+171C 171E (fig-forth-auto680):02070 OVER FDB *+NATWID
2074+171E EC42 (fig-forth-auto680):02071 LDD NATWID,U
2075+1720 3606 (fig-forth-auto680):02072 PSHU D
2076+1722 39 (fig-forth-auto680):02073 RTS
2077+ (fig-forth-auto680):02074 * TFR S,X ; TSX :
2078+ (fig-forth-auto680):02075 * LDA 2,X
2079+ (fig-forth-auto680):02076 * LDB 3,X
2080+ (fig-forth-auto680):02077 * JMP PUSHBA
2081+ (fig-forth-auto680):02078 *
2082+ (fig-forth-auto680):02079 * ======>> 38 <<
2083+ (fig-forth-auto680):02080 * ( n --- )
2084+ (fig-forth-auto680):02081 * Discard the top word on stack.
2085+1723 84 (fig-forth-auto680):02082 FCB $84
2086+1724 44524F (fig-forth-auto680):02083 FCC 'DRO' ; 'DROP'
2087+1727 D0 (fig-forth-auto680):02084 FCB $D0
2088+1728 1715 (fig-forth-auto680):02085 FDB OVER-7
2089+172A 172C (fig-forth-auto680):02086 DROP FDB *+NATWID
2090+172C 3342 (fig-forth-auto680):02087 LEAU NATWID,U
2091+172E 39 (fig-forth-auto680):02088 RTS
2092+ (fig-forth-auto680):02089 * LEAS 1,S ;
2093+ (fig-forth-auto680):02090 * LEAS 1,S ;
2094+ (fig-forth-auto680):02091 * JMP NEXT
2095+ (fig-forth-auto680):02092 *
2096+ (fig-forth-auto680):02093 * ======>> 39 <<
2097+ (fig-forth-auto680):02094 * ( n1 n2 --- n2 n1 )
2098+ (fig-forth-auto680):02095 * Swap the top two words on stack.
2099+172F 84 (fig-forth-auto680):02096 FCB $84
2100+1730 535741 (fig-forth-auto680):02097 FCC 'SWA' ; 'SWAP'
2101+1733 D0 (fig-forth-auto680):02098 FCB $D0
2102+1734 1723 (fig-forth-auto680):02099 FDB DROP-7
2103+1736 1738 (fig-forth-auto680):02100 SWAP FDB *+NATWID
2104+1738 3716 (fig-forth-auto680):02101 PULU D,X
2105+173A 3606 (fig-forth-auto680):02102 PSHU D
2106+173C 3610 (fig-forth-auto680):02103 PSHU X
2107+173E 39 (fig-forth-auto680):02104 RTS
2108+ (fig-forth-auto680):02105 * PULS A ;
2109+ (fig-forth-auto680):02106 * PULS B ;
2110+ (fig-forth-auto680):02107 * TFR S,X ; TSX :
2111+ (fig-forth-auto680):02108 * LDX 0,X
2112+ (fig-forth-auto680):02109 * LEAS 1,S ;
2113+ (fig-forth-auto680):02110 * LEAS 1,S ;
2114+ (fig-forth-auto680):02111 * PSHS B ;
2115+ (fig-forth-auto680):02112 * PSHS A ;
2116+ (fig-forth-auto680):02113 * STX N
2117+ (fig-forth-auto680):02114 * LDX #N
2118+ (fig-forth-auto680):02115 * JMP GETX
2119+ (fig-forth-auto680):02116 *
2120+ (fig-forth-auto680):02117 * ======>> 40 <<
2121+ (fig-forth-auto680):02118 * ( n1 --- n1 n1 )
2122+ (fig-forth-auto680):02119 * Push a copy of the top word on stack.
2123+173F 83 (fig-forth-auto680):02120 FCB $83
2124+1740 4455 (fig-forth-auto680):02121 FCC 'DU' ; 'DUP'
2125+1742 D0 (fig-forth-auto680):02122 FCB $D0
2126+1743 172F (fig-forth-auto680):02123 FDB SWAP-7
2127+1745 1747 (fig-forth-auto680):02124 DUP FDB *+NATWID
2128+1747 ECC4 (fig-forth-auto680):02125 LDD ,U
2129+1749 3606 (fig-forth-auto680):02126 PSHU D
2130+174B 39 (fig-forth-auto680):02127 RTS
2131+ (fig-forth-auto680):02128 * PULS A ;
2132+ (fig-forth-auto680):02129 * PULS B ;
2133+ (fig-forth-auto680):02130 * PSHS B ;
2134+ (fig-forth-auto680):02131 * PSHS A ;
2135+ (fig-forth-auto680):02132 * JMP PUSHBA
2136+ (fig-forth-auto680):02133 *
2137+ (fig-forth-auto680):02134 * ######>> screen 31 <<
2138+ (fig-forth-auto680):02135 * ======>> 41 <<
2139+ (fig-forth-auto680):02136 * ( n adr --- )
2140+ (fig-forth-auto680):02137 * Add the second word on stack to the word at the adr on top of stack.
2141+174C 82 (fig-forth-auto680):02138 FCB $82
2142+174D 2B (fig-forth-auto680):02139 FCC '+' ; '+!'
2143+174E A1 (fig-forth-auto680):02140 FCB $A1
2144+174F 173F (fig-forth-auto680):02141 FDB DUP-6
2145+1751 1753 (fig-forth-auto680):02142 PSTORE FDB *+NATWID
2146+1753 3710 (fig-forth-auto680):02143 PULU X
2147+1755 EC84 (fig-forth-auto680):02144 LDD ,X
2148+1757 E3C1 (fig-forth-auto680):02145 ADDD ,U++
2149+1759 ED84 (fig-forth-auto680):02146 STD ,X
2150+175B 39 (fig-forth-auto680):02147 RTS
2151+ (fig-forth-auto680):02148 * TFR S,X ; TSX :
2152+ (fig-forth-auto680):02149 * LDX 0,X
2153+ (fig-forth-auto680):02150 * LEAS 1,S ;
2154+ (fig-forth-auto680):02151 * LEAS 1,S ;
2155+ (fig-forth-auto680):02152 * PULS A ; get stack data
2156+ (fig-forth-auto680):02153 * PULS B ;
2157+ (fig-forth-auto680):02154 * ADDB 1,X add & store low byte
2158+ (fig-forth-auto680):02155 * STB 1,X
2159+ (fig-forth-auto680):02156 * ADCA 0,X add & store hi byte
2160+ (fig-forth-auto680):02157 * STA 0,X
2161+ (fig-forth-auto680):02158 * JMP NEXT
2162+ (fig-forth-auto680):02159 *
2163+ (fig-forth-auto680):02160 * ======>> 42 <<
2164+ (fig-forth-auto680):02161 * ( adr b --- )
2165+ (fig-forth-auto680):02162 * Exclusive or byte at adr with low byte of top word.
2166+175C 86 (fig-forth-auto680):02163 FCB $86
2167+175D 544F47474C (fig-forth-auto680):02164 FCC 'TOGGL' ; 'TOGGLE'
2168+1762 C5 (fig-forth-auto680):02165 FCB $C5
2169+1763 174C (fig-forth-auto680):02166 FDB PSTORE-5
2170+1765 1767 (fig-forth-auto680):02167 TOGGLE FDB *+NATWID
2171+1767 3716 (fig-forth-auto680):02168 PULU D,X
2172+1769 E884 (fig-forth-auto680):02169 EORB ,X
2173+176B E784 (fig-forth-auto680):02170 STB ,X
2174+176D 39 (fig-forth-auto680):02171 RTS
2175+ (fig-forth-auto680):02172 * Using the model code would be less likely to introduce bugs,
2176+ (fig-forth-auto680):02173 * but that would sort-of defeat my purposes here.
2177+ (fig-forth-auto680):02174 * Anyway, I can borrow from theoretically known good bif-6809 code
2178+ (fig-forth-auto680):02175 * and it's fewer bytes and much faster code this way.
2179+ (fig-forth-auto680):02176 * TOGGLE
2180+ (fig-forth-auto680):02177 * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
2181+ (fig-forth-auto680):02178 * FDB SEMIS
2182+ (fig-forth-auto680):02179 *
2183+ (fig-forth-auto680):02180 * ######>> screen 32 <<
2184+ (fig-forth-auto680):02181 * ======>> 43 <<
2185+ (fig-forth-auto680):02182 * ( adr --- n )
2186+ (fig-forth-auto680):02183 * Replace address on stack with the word at the address.
2187+176E 81 (fig-forth-auto680):02184 FCB $81 @
2188+176F C0 (fig-forth-auto680):02185 FCB $C0
2189+1770 175C (fig-forth-auto680):02186 FDB TOGGLE-9
2190+1772 1774 (fig-forth-auto680):02187 AT FDB *+NATWID
2191+1774 ECD4 (fig-forth-auto680):02188 LDD [,U]
2192+1776 EDC4 (fig-forth-auto680):02189 STD ,U
2193+1778 39 (fig-forth-auto680):02190 RTS
2194+ (fig-forth-auto680):02191 * TFR S,X ; TSX :
2195+ (fig-forth-auto680):02192 * LDX 0,X get address
2196+ (fig-forth-auto680):02193 * LEAS 1,S ;
2197+ (fig-forth-auto680):02194 * LEAS 1,S ;
2198+ (fig-forth-auto680):02195 * JMP GETX
2199+ (fig-forth-auto680):02196 *
2200+ (fig-forth-auto680):02197 * ======>> 44 <<
2201+ (fig-forth-auto680):02198 * ( adr --- b )
2202+ (fig-forth-auto680):02199 * Replace address on top of stack with the byte at the address.
2203+ (fig-forth-auto680):02200 * High byte of result is clear.
2204+1779 82 (fig-forth-auto680):02201 FCB $82
2205+177A 43 (fig-forth-auto680):02202 FCC 'C' ; 'C@'
2206+177B C0 (fig-forth-auto680):02203 FCB $C0
2207+177C 176E (fig-forth-auto680):02204 FDB AT-4
2208+177E 1780 (fig-forth-auto680):02205 CAT FDB *+NATWID
2209+1780 E6D4 (fig-forth-auto680):02206 LDB [,U]
2210+1782 4F (fig-forth-auto680):02207 CLRA
2211+1783 EDC4 (fig-forth-auto680):02208 STD ,U
2212+1785 39 (fig-forth-auto680):02209 RTS
2213+ (fig-forth-auto680):02210
2214+ (fig-forth-auto680):02211
2215+ (fig-forth-auto680):02212 * TFR S,X ; TSX :
2216+ (fig-forth-auto680):02213 * LDX 0,X
2217+ (fig-forth-auto680):02214 * CLRA ;
2218+ (fig-forth-auto680):02215 * LDB 0,X
2219+ (fig-forth-auto680):02216 * LEAS 1,S ;
2220+ (fig-forth-auto680):02217 * LEAS 1,S ;
2221+ (fig-forth-auto680):02218 * JMP PUSHBA
2222+ (fig-forth-auto680):02219 *
2223+ (fig-forth-auto680):02220 * ======>> 45 <<
2224+ (fig-forth-auto680):02221 * ( n adr --- )
2225+ (fig-forth-auto680):02222 * Store second word on stack at address on top of stack.
2226+1786 81 (fig-forth-auto680):02223 FCB $81
2227+1787 A1 (fig-forth-auto680):02224 FCB $A1
2228+1788 1779 (fig-forth-auto680):02225 FDB CAT-5
2229+178A 178C (fig-forth-auto680):02226 STORE FDB *+NATWID
2230+178C EC42 (fig-forth-auto680):02227 LDD NATWID,U
2231+178E EDD4 (fig-forth-auto680):02228 STD [,U]
2232+1790 3344 (fig-forth-auto680):02229 LEAU 2*NATWID,U
2233+1792 39 (fig-forth-auto680):02230 RTS
2234+ (fig-forth-auto680):02231 * TFR S,X ; TSX :
2235+ (fig-forth-auto680):02232 * LDX 0,X get address
2236+ (fig-forth-auto680):02233 * LEAS 1,S ;
2237+ (fig-forth-auto680):02234 * LEAS 1,S ;
2238+ (fig-forth-auto680):02235 * JMP PULABX
2239+ (fig-forth-auto680):02236 *
2240+ (fig-forth-auto680):02237 * ======>> 46 <<
2241+ (fig-forth-auto680):02238 * ( b adr --- )
2242+ (fig-forth-auto680):02239 * Store low byte of second word on stack at address on top of stack.
2243+ (fig-forth-auto680):02240 * High byte is ignored.
2244+1793 82 (fig-forth-auto680):02241 FCB $82
2245+1794 43 (fig-forth-auto680):02242 FCC 'C' ; 'C!'
2246+1795 A1 (fig-forth-auto680):02243 FCB $A1
2247+1796 1786 (fig-forth-auto680):02244 FDB STORE-4
2248+1798 179A (fig-forth-auto680):02245 CSTORE FDB *+NATWID
2249+179A E643 (fig-forth-auto680):02246 LDB 3,U
2250+179C E7D4 (fig-forth-auto680):02247 STB [,U]
2251+179E 3344 (fig-forth-auto680):02248 LEAU 2*NATWID,U
2252+17A0 39 (fig-forth-auto680):02249 RTS
2253+ (fig-forth-auto680):02250 * TFR S,X ; TSX :
2254+ (fig-forth-auto680):02251 * LDX 0,X get address
2255+ (fig-forth-auto680):02252 * LEAS 1,S ;
2256+ (fig-forth-auto680):02253 * LEAS 1,S ;
2257+ (fig-forth-auto680):02254 * LEAS 1,S ;
2258+ (fig-forth-auto680):02255 * PULS B ;
2259+ (fig-forth-auto680):02256 * STB 0,X
2260+ (fig-forth-auto680):02257 * JMP NEXT
2261+ (fig-forth-auto680):02258 PAGE
2262+ (fig-forth-auto680):02259 *
2263+ (fig-forth-auto680):02260 * ######>> screen 33 <<
2264+ (fig-forth-auto680):02261 * ======>> 47 <<
2265+ (fig-forth-auto680):02262 * ( --- ) P
2266+ (fig-forth-auto680):02263 * { : name sundry-activities ; } typical input
2267+ (fig-forth-auto680):02264 * If executing (not compiling),
2268+ (fig-forth-auto680):02265 * record the data stack mark in CSP,
2269+ (fig-forth-auto680):02266 * Set the CONTEXT vocabulary to CURRENT,
2270+ (fig-forth-auto680):02267 * CREATE a header,
2271+ (fig-forth-auto680):02268 * set state to compile,
2272+ (fig-forth-auto680):02269 * and compile the call to the trailing native CPU machine code DOCOL.
2273+ (fig-forth-auto680):02270 *
2274+ (fig-forth-auto680):02271 * This would not be hard to flatten to native code.
2275+ (fig-forth-auto680):02272 * But that's not the purpose of a model.
2276+17A1 C1 (fig-forth-auto680):02273 FCB $C1 : immediate
2277+17A2 BA (fig-forth-auto680):02274 FCB $BA
2278+17A3 1793 (fig-forth-auto680):02275 FDB CSTORE-5
2279+17A5 17B91B6A1B26194C (fig-forth-auto680):02276 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
2280+ 1772193E178A
2281+17B3 20661BEB (fig-forth-auto680):02277 FDB CREATE,RBRAK
2282+17B7 1C3A (fig-forth-auto680):02278 FDB PSCODE
2283+ (fig-forth-auto680):02279
2284+ (fig-forth-auto680):02280 * Here is the IP pusher for allowing
2285+ (fig-forth-auto680):02281 * nested words in the virtual machine:
2286+ (fig-forth-auto680):02282 * ( ;S is the equivalent un-nester )
2287+ (fig-forth-auto680):02283
2288+ (fig-forth-auto680):02284 * ( *** oldIP )
2289+ (fig-forth-auto680):02285 * Characteristic of a colon (:) definition.
2290+ (fig-forth-auto680):02286 * Begins execution of a high-level definition,
2291+ (fig-forth-auto680):02287 * i. e., nests the definition and begins processing icodes.
2292+ (fig-forth-auto680):02288 * Mechanically, it pushes the IP (Y register)
2293+ (fig-forth-auto680):02289 * and loads the Parameter Field Address of the definition which
2294+ (fig-forth-auto680):02290 * called it into the IP.
2295+17B9 ECE4 (fig-forth-auto680):02291 DOCOL LDD ,S ; Save the return address.
2296+17BB 10AFE4 (fig-forth-auto680):02292 STY ,S ; Nest the old IP.
2297+17BE 3102 (fig-forth-auto680):02293 LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
2298+17C0 1F05 (fig-forth-auto680):02294 TFR D,PC ; synthetic return to interpret.
2299+ (fig-forth-auto680):02295
2300+ (fig-forth-auto680):02296 * DOCOL LDX RP make room in the stack
2301+ (fig-forth-auto680):02297 * LEAX -1,X ;
2302+ (fig-forth-auto680):02298 * LEAX -1,X ;
2303+ (fig-forth-auto680):02299 * STX RP
2304+ (fig-forth-auto680):02300 * LDA IP
2305+ (fig-forth-auto680):02301 * LDB IP+1
2306+ (fig-forth-auto680):02302 * STA 2,X Store address of the high level word
2307+ (fig-forth-auto680):02303 * STB 3,X that we are starting to execute
2308+ (fig-forth-auto680):02304 * LDX W Get first sub-word of that definition
2309+ (fig-forth-auto680):02305 * JMP NEXT+2 and execute it
2310+ (fig-forth-auto680):02306 *
2311+ (fig-forth-auto680):02307 * ======>> 48 <<
2312+ (fig-forth-auto680):02308 * ( --- ) P
2313+ (fig-forth-auto680):02309 * { : name sundry-activities ; } typical input
2314+ (fig-forth-auto680):02310 * ERROR check data stack against mark in CSP,
2315+ (fig-forth-auto680):02311 * compile ;S,
2316+ (fig-forth-auto680):02312 * unSMUDGE LATEST definition,
2317+ (fig-forth-auto680):02313 * and set state to interpretation.
2318+17C2 C1 (fig-forth-auto680):02314 FCB $C1 ; imnediate code
2319+17C3 BB (fig-forth-auto680):02315 FCB $BB
2320+17C4 17A1 (fig-forth-auto680):02316 FDB COLON-4
2321+17C6 17B91B921BC71667 (fig-forth-auto680):02317 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
2322+ 1BFF1BDD
2323+17D2 1667 (fig-forth-auto680):02318 FDB SEMIS
2324+ (fig-forth-auto680):02319 *
2325+ (fig-forth-auto680):02320 * ######>> screen 34 <<
2326+ (fig-forth-auto680):02321 * ======>> 49 <<
2327+ (fig-forth-auto680):02322 * ( n --- )
2328+ (fig-forth-auto680):02323 * { value CONSTANT name } typical input
2329+ (fig-forth-auto680):02324 * CREATE a header,
2330+ (fig-forth-auto680):02325 * unSMUDGE it,
2331+ (fig-forth-auto680):02326 * compile the constant value,
2332+ (fig-forth-auto680):02327 * and compile the call to the trailing native CPU machine code DOCON.
2333+17D4 88 (fig-forth-auto680):02328 FCB $88
2334+17D5 434F4E5354414E (fig-forth-auto680):02329 FCC 'CONSTAN' ; 'CONSTANT'
2335+17DC D4 (fig-forth-auto680):02330 FCB $D4
2336+17DD 17C2 (fig-forth-auto680):02331 FDB SEMI-4
2337+17DF 17B920661BFF19E3 (fig-forth-auto680):02332 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
2338+ 1C3A
2339+ (fig-forth-auto680):02333 * ( --- n )
2340+ (fig-forth-auto680):02334 * Characteristic of a CONSTANT.
2341+ (fig-forth-auto680):02335 * A CONSTANT simply loads its value from its parameter field
2342+ (fig-forth-auto680):02336 * and pushes it on the stack.
2343+17E9 EC02 (fig-forth-auto680):02337 DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
2344+17EB 3606 (fig-forth-auto680):02338 PSHU D
2345+17ED 39 (fig-forth-auto680):02339 RTS
2346+ (fig-forth-auto680):02340 * DOCON LDX W
2347+ (fig-forth-auto680):02341 * LDA 2,X
2348+ (fig-forth-auto680):02342 * LDB 3,X A & B now contain the constant
2349+ (fig-forth-auto680):02343 * JMP PUSHBA
2350+ (fig-forth-auto680):02344 *
2351+ (fig-forth-auto680):02345 * Not in model, needed for abstraction:
2352+ (fig-forth-auto680):02346 * ( --- NATWID )
2353+ (fig-forth-auto680):02347 * The byte width of objects on stack.
2354+17EE 86 (fig-forth-auto680):02348 FCB $86
2355+17EF 4E41545749 (fig-forth-auto680):02349 FCC 'NATWI' ; 'NATWID'
2356+17F4 C4 (fig-forth-auto680):02350 FCB $C4
2357+17F5 17D4 (fig-forth-auto680):02351 FDB CON-11
2358+17F7 17E9 (fig-forth-auto680):02352 NATWC FDB DOCON
2359+17F9 0002 (fig-forth-auto680):02353 NATWCV FDB NATWID
2360+ (fig-forth-auto680):02354 *
2361+ (fig-forth-auto680):02355 * Not in model, needed for abstraction:
2362+ (fig-forth-auto680):02356 * Note that this is not defined as an INCREMENTER!
2363+ (fig-forth-auto680):02357 * Coded to increment by the exact constant returned by NATWID
2364+ (fig-forth-auto680):02358 * ( n --- n+NATWID )
2365+17FB 84 (fig-forth-auto680):02359 FCB $84
2366+17FC 4E4154 (fig-forth-auto680):02360 FCC 'NAT' ; 'NAT+'
2367+17FF AB (fig-forth-auto680):02361 FCB $AB
2368+1800 17EE (fig-forth-auto680):02362 FDB NATWC-9
2369+1802 1804 (fig-forth-auto680):02363 NATP FDB *+NATWID
2370+1804 ECC4 (fig-forth-auto680):02364 LDD ,U
2371+1806 E38CF0 (fig-forth-auto680):02365 ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
2372+1809 EDC4 (fig-forth-auto680):02366 STD ,U
2373+180B 39 (fig-forth-auto680):02367 RTS
2374+ (fig-forth-auto680):02368 * How this might have been done for 6800 model:
2375+ (fig-forth-auto680):02369 * CLRA ; We know the natural width is less than 255, LOL.
2376+ (fig-forth-auto680):02370 * LDAB NATWCV+1
2377+ (fig-forth-auto680):02371 * TSX
2378+ (fig-forth-auto680):02372 * ADDB 1,X
2379+ (fig-forth-auto680):02373 * ADCA ,X
2380+ (fig-forth-auto680):02374 * JMP STABX
2381+ (fig-forth-auto680):02375 *
2382+ (fig-forth-auto680):02376 * ======>> 50 <<
2383+ (fig-forth-auto680):02377 * ( init --- )
2384+ (fig-forth-auto680):02378 * { init VARIABLE name } typical input
2385+ (fig-forth-auto680):02379 * Use CONSTANT to CREATE a header and compile the initial value, init,
2386+ (fig-forth-auto680):02380 * then overwrite the characteristic to point to DOVAR.
2387+180C 88 (fig-forth-auto680):02381 FCB $88
2388+180D 5641524941424C (fig-forth-auto680):02382 FCC 'VARIABL' ; 'VARIABLE'
2389+1814 C5 (fig-forth-auto680):02383 FCB $C5
2390+1815 17FB (fig-forth-auto680):02384 FDB NATP-7
2391+1817 17B917DF1C3A (fig-forth-auto680):02385 VAR FDB DOCOL,CON,PSCODE
2392+ (fig-forth-auto680):02386 * ( --- vadr )
2393+ (fig-forth-auto680):02387 * Characteristic of a VARIABLE.
2394+ (fig-forth-auto680):02388 * A VARIABLE pushes its PFA address on the stack.
2395+ (fig-forth-auto680):02389 * The parameter field of a VARIABLE is the actual allocation of the variable,
2396+ (fig-forth-auto680):02390 * so that pushing its address allows its contents to be @ed (fetched).
2397+ (fig-forth-auto680):02391 * Ordinary arrays and strings that do not subscript themselves
2398+ (fig-forth-auto680):02392 * may be allocated by defining a variable
2399+ (fig-forth-auto680):02393 * and immediately ALLOTting the remaining needed space.
2400+ (fig-forth-auto680):02394 * VARIABLES are global to all users,
2401+ (fig-forth-auto680):02395 * and thus should be hidden in resource monitors, but aren't.
2402+181D 3002 (fig-forth-auto680):02396 DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
2403+181F 3610 (fig-forth-auto680):02397 PSHU X
2404+1821 39 (fig-forth-auto680):02398 RTS
2405+ (fig-forth-auto680):02399 * DOVAR LDA W
2406+ (fig-forth-auto680):02400 * LDB W+1
2407+ (fig-forth-auto680):02401 * ADDB #2
2408+ (fig-forth-auto680):02402 * ADCA #0 A,B now contain the address of the variable
2409+ (fig-forth-auto680):02403 * JMP PUSHBA
2410+ (fig-forth-auto680):02404 *
2411+ (fig-forth-auto680):02405 * ======>> 51 <<
2412+ (fig-forth-auto680):02406 * ( ub --- )
2413+ (fig-forth-auto680):02407 * { uboffset USER name } typical input
2414+ (fig-forth-auto680):02408 * CREATE a header and compile the unsigned byte offset in the per-USER table,
2415+ (fig-forth-auto680):02409 * then overwrite the header with a call to DOUSER.
2416+ (fig-forth-auto680):02410 * The USER is entirely responsible for maintaining allocation!
2417+1822 84 (fig-forth-auto680):02411 FCB $84
2418+1823 555345 (fig-forth-auto680):02412 FCC 'USE' ; 'USER'
2419+1826 D2 (fig-forth-auto680):02413 FCB $D2
2420+1827 180C (fig-forth-auto680):02414 FDB VAR-11
2421+1829 17B917DF1C3A (fig-forth-auto680):02415 USER FDB DOCOL,CON,PSCODE
2422+ (fig-forth-auto680):02416 * ( --- vadr )
2423+ (fig-forth-auto680):02417 * Characteristic of a per-USER variable.
2424+ (fig-forth-auto680):02418 * USER variables are similiar to VARIABLEs,
2425+ (fig-forth-auto680):02419 * but are allocated (by hand!) in the per-user table.
2426+ (fig-forth-auto680):02420 * A USER variable's parameter field contains its offset in the per-user table.
2427+182F 1FB8 (fig-forth-auto680):02421 DOUSER TFR DP,A ; Make a pointer to the direct page.
2428+1831 5F (fig-forth-auto680):02422 CLRB
2429+ (fig-forth-auto680):02423 * See Alternative -- alternatives start from this point.
2430+1832 E302 (fig-forth-auto680):02424 ADDD NATWID,X ; Add it to the offset to the per-user variable.
2431+1834 3606 (fig-forth-auto680):02425 PSHU D
2432+1836 1F01 (fig-forth-auto680):02426 TFR D,X ; Cache the pointer in X for the caller.
2433+1838 39 (fig-forth-auto680):02427 RTS
2434+ (fig-forth-auto680):02428 * Hey, the per-user table could actually be larger than 256 bytes!
2435+ (fig-forth-auto680):02429 * But we knew that. It's just not as esthetic to calculate it this way.
2436+ (fig-forth-auto680):02430 * Alternative A:
2437+ (fig-forth-auto680):02431 * LDX NATWID,X ; Keep the offset
2438+ (fig-forth-auto680):02432 * EXG D,X ; Prepare for EA
2439+ (fig-forth-auto680):02433 * LEAX D,X
2440+ (fig-forth-auto680):02434 * PSHU X
2441+ (fig-forth-auto680):02435 * RTS
2442+ (fig-forth-auto680):02436 * Alternative B:
2443+ (fig-forth-auto680):02437 * PSHS Y ; Get Y free for calculations.
2444+ (fig-forth-auto680):02438 * TFR D,Y ; Y points to the UP base
2445+ (fig-forth-auto680):02439 * LDD NATWID,X ; Get the offset
2446+ (fig-forth-auto680):02440 * LEAX D,Y ; Leave the pointer cached in X.
2447+ (fig-forth-auto680):02441 * PSHU X
2448+ (fig-forth-auto680):02442 * PULS Y,PC
2449+ (fig-forth-auto680):02443 *
2450+ (fig-forth-auto680):02444 * From the 6800 model:
2451+ (fig-forth-auto680):02445 * DOUSER LDX W get offset into user's table
2452+ (fig-forth-auto680):02446 * LDA 2,X
2453+ (fig-forth-auto680):02447 * LDB 3,X
2454+ (fig-forth-auto680):02448 * ADDB UP+1 add to users base address
2455+ (fig-forth-auto680):02449 * ADCA UP
2456+ (fig-forth-auto680):02450 * JMP PUSHBA push address of user's variable
2457+ (fig-forth-auto680):02451 *
2458+ (fig-forth-auto680):02452 * ######>> screen 35 <<
2459+ (fig-forth-auto680):02453 * ======>> 52 <<
2460+ (fig-forth-auto680):02454 * ( --- 0 )
2461+1839 81 (fig-forth-auto680):02455 FCB $81
2462+183A B0 (fig-forth-auto680):02456 FCB $B0 0
2463+183B 1822 (fig-forth-auto680):02457 FDB USER-7
2464+183D 17E9 (fig-forth-auto680):02458 ZERO FDB DOCON
2465+183F 0000 (fig-forth-auto680):02459 FDB 0000
2466+ (fig-forth-auto680):02460 *
2467+ (fig-forth-auto680):02461 * ======>> 53 <<
2468+ (fig-forth-auto680):02462 * ( --- 1 )
2469+1841 81 (fig-forth-auto680):02463 FCB $81
2470+1842 B1 (fig-forth-auto680):02464 FCB $B1 1
2471+1843 1839 (fig-forth-auto680):02465 FDB ZERO-4
2472+1845 17E9 (fig-forth-auto680):02466 ONE FDB DOCON
2473+1847 0001 (fig-forth-auto680):02467 ONEV FDB 1
2474+ (fig-forth-auto680):02468 *
2475+ (fig-forth-auto680):02469 * ======>> 54 <<
2476+ (fig-forth-auto680):02470 * ( --- 2 )
2477+1849 81 (fig-forth-auto680):02471 FCB $81
2478+184A B2 (fig-forth-auto680):02472 FCB $B2 2
2479+184B 1841 (fig-forth-auto680):02473 FDB ONE-4
2480+184D 17E9 (fig-forth-auto680):02474 TWO FDB DOCON
2481+184F 0002 (fig-forth-auto680):02475 TWOV FDB 2
2482+ (fig-forth-auto680):02476 *
2483+ (fig-forth-auto680):02477 * ======>> 55 <<
2484+ (fig-forth-auto680):02478 * ( --- 3 )
2485+1851 81 (fig-forth-auto680):02479 FCB $81
2486+1852 B3 (fig-forth-auto680):02480 FCB $B3 3
2487+1853 1849 (fig-forth-auto680):02481 FDB TWO-4
2488+1855 17E9 (fig-forth-auto680):02482 THREE FDB DOCON
2489+1857 0003 (fig-forth-auto680):02483 FDB 3
2490+ (fig-forth-auto680):02484 *
2491+ (fig-forth-auto680):02485 * ======>> 56 <<
2492+ (fig-forth-auto680):02486 * ( --- SP )
2493+ (fig-forth-auto680):02487 * ASCII SPACE character
2494+1859 82 (fig-forth-auto680):02488 FCB $82
2495+185A 42 (fig-forth-auto680):02489 FCC 'B' ; 'BL'
2496+185B CC (fig-forth-auto680):02490 FCB $CC
2497+185C 1851 (fig-forth-auto680):02491 FDB THREE-4
2498+185E 17E9 (fig-forth-auto680):02492 BL FDB DOCON ascii blank
2499+1860 0020 (fig-forth-auto680):02493 FDB $20
2500+ (fig-forth-auto680):02494 *
2501+ (fig-forth-auto680):02495 * ======>> 57 <<
2502+ (fig-forth-auto680):02496 * This really shouldn't be a CONSTANT.
2503+ (fig-forth-auto680):02497 * ( --- adr )
2504+ (fig-forth-auto680):02498 * The base of the disk buffer space.
2505+1862 85 (fig-forth-auto680):02499 FCB $85
2506+1863 46495253 (fig-forth-auto680):02500 FCC 'FIRS' ; 'FIRST'
2507+1867 D4 (fig-forth-auto680):02501 FCB $D4
2508+1868 1859 (fig-forth-auto680):02502 FDB BL-5
2509+186A 17E9 (fig-forth-auto680):02503 FIRST FDB DOCON
2510+186C 6BE0 (fig-forth-auto680):02504 FDB BUFBAS
2511+ (fig-forth-auto680):02505 * FDB MEMEND-528 (132 * NBLK)
2512+ (fig-forth-auto680):02506 *
2513+ (fig-forth-auto680):02507 * ======>> 58 <<
2514+ (fig-forth-auto680):02508 * This really shouldn't be a CONSTANT.
2515+ (fig-forth-auto680):02509 * ( --- adr )
2516+ (fig-forth-auto680):02510 * The limit of the disk buffer space.
2517+186E 85 (fig-forth-auto680):02511 FCB $85
2518+186F 4C494D49 (fig-forth-auto680):02512 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
2519+1873 D4 (fig-forth-auto680):02513 FCB $D4
2520+1874 1862 (fig-forth-auto680):02514 FDB FIRST-8
2521+1876 17E9 (fig-forth-auto680):02515 LIMIT FDB DOCON
2522+1878 7000 (fig-forth-auto680):02516 FDB BUFBAS+BUFSZ
2523+ (fig-forth-auto680):02517 * In 6800 model, was
2524+ (fig-forth-auto680):02518 * FDB MEMEND
2525+ (fig-forth-auto680):02519 *
2526+ (fig-forth-auto680):02520 * ======>> 59 <<
2527+ (fig-forth-auto680):02521 * ( --- sectorsize )
2528+ (fig-forth-auto680):02522 * The size, in bytes, of a buffer.
2529+187A 85 (fig-forth-auto680):02523 FCB $85
2530+187B 422F4255 (fig-forth-auto680):02524 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
2531+187F C6 (fig-forth-auto680):02525 FCB $C6
2532+1880 186E (fig-forth-auto680):02526 FDB LIMIT-8
2533+1882 17E9 (fig-forth-auto680):02527 BBUF FDB DOCON
2534+1884 0100 (fig-forth-auto680):02528 FDB SECTSZ
2535+ (fig-forth-auto680):02529 * Hardcoded in 6800 model:
2536+ (fig-forth-auto680):02530 * FDB 128
2537+ (fig-forth-auto680):02531 *
2538+ (fig-forth-auto680):02532 * ======>> 60 <<
2539+ (fig-forth-auto680):02533 * ( --- blocksperscreen )
2540+ (fig-forth-auto680):02534 * The size, in blocks, of a screen.
2541+ (fig-forth-auto680):02535 * Should this be the same as NBLK, the number of block buffers maintained?
2542+1886 85 (fig-forth-auto680):02536 FCB $85
2543+1887 422F5343 (fig-forth-auto680):02537 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
2544+188B D2 (fig-forth-auto680):02538 FCB $D2
2545+188C 187A (fig-forth-auto680):02539 FDB BBUF-8
2546+188E 17E9 (fig-forth-auto680):02540 BSCR FDB DOCON
2547+1890 0004 (fig-forth-auto680):02541 FDB SCRSZ/SECTSZ
2548+ (fig-forth-auto680):02542 * Hardcoded in 6800 model as:
2549+ (fig-forth-auto680):02543 * FDB 8
2550+ (fig-forth-auto680):02544 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
2551+ (fig-forth-auto680):02545 *
2552+ (fig-forth-auto680):02546 * ======>> 61 <<
2553+ (fig-forth-auto680):02547 * ( n --- adr )
2554+ (fig-forth-auto680):02548 * Calculate the address of entry (#n/2) in the boot-up parameter table.
2555+ (fig-forth-auto680):02549 * (Adds the base of the boot-up table to n.)
2556+1892 87 (fig-forth-auto680):02550 FCB $87
2557+1893 2B4F52494749 (fig-forth-auto680):02551 FCC '+ORIGI' ; '+ORIGIN'
2558+1899 CE (fig-forth-auto680):02552 FCB $CE
2559+189A 1886 (fig-forth-auto680):02553 FDB BSCR-8
2560+189C 17B91399120016C6 (fig-forth-auto680):02554 PORIG FDB DOCOL,LIT,ORIG,PLUS
2561+18A4 1667 (fig-forth-auto680):02555 FDB SEMIS
2562+ (fig-forth-auto680):02556 *
2563+ (fig-forth-auto680):02557 * ######>> screen 36 <<
2564+ (fig-forth-auto680):02558 * ======>> 62 <<
2565+ (fig-forth-auto680):02559 * ( n --- adr )
2566+ (fig-forth-auto680):02560 * This is the per-task variable recording the initial parameter stack pointer.
2567+18A6 82 (fig-forth-auto680):02561 FCB $82
2568+18A7 53 (fig-forth-auto680):02562 FCC 'S' ; 'S0'
2569+18A8 B0 (fig-forth-auto680):02563 FCB $B0
2570+18A9 1892 (fig-forth-auto680):02564 FDB PORIG-10
2571+18AB 182F (fig-forth-auto680):02565 SZERO FDB DOUSER
2572+18AD 001E (fig-forth-auto680):02566 FDB XSPZER-UORIG
2573+ (fig-forth-auto680):02567 *
2574+ (fig-forth-auto680):02568 * ======>> 63 <<
2575+ (fig-forth-auto680):02569 * ( n --- adr )
2576+ (fig-forth-auto680):02570 * This is the per-task variable recording the initial return stack pointer.
2577+18AF 82 (fig-forth-auto680):02571 FCB $82
2578+18B0 52 (fig-forth-auto680):02572 FCC 'R' ; 'R0'
2579+18B1 B0 (fig-forth-auto680):02573 FCB $B0
2580+18B2 18A6 (fig-forth-auto680):02574 FDB SZERO-5
2581+18B4 182F (fig-forth-auto680):02575 RZERO FDB DOUSER
2582+18B6 0020 (fig-forth-auto680):02576 FDB XRZERO-UORIG
2583+ (fig-forth-auto680):02577 *
2584+ (fig-forth-auto680):02578 * ======>> 64 <<
2585+ (fig-forth-auto680):02579 * ( --- vadr )
2586+ (fig-forth-auto680):02580 * Terminal Input Buffer address.
2587+ (fig-forth-auto680):02581 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
2588+18B8 83 (fig-forth-auto680):02582 FCB $83
2589+18B9 5449 (fig-forth-auto680):02583 FCC 'TI' ; 'TIB'
2590+18BB C2 (fig-forth-auto680):02584 FCB $C2
2591+18BC 18AF (fig-forth-auto680):02585 FDB RZERO-5
2592+18BE 182F (fig-forth-auto680):02586 TIB FDB DOUSER
2593+18C0 0022 (fig-forth-auto680):02587 FDB XTIB-UORIG
2594+ (fig-forth-auto680):02588 *
2595+ (fig-forth-auto680):02589 * ======>> 65 <<
2596+ (fig-forth-auto680):02590 * ( --- maxnamewidth )
2597+ (fig-forth-auto680):02591 * This is the maximum width to which symbol names will be recorded.
2598+18C2 85 (fig-forth-auto680):02592 FCB $85
2599+18C3 57494454 (fig-forth-auto680):02593 FCC 'WIDT' ; 'WIDTH'
2600+18C7 C8 (fig-forth-auto680):02594 FCB $C8
2601+18C8 18B8 (fig-forth-auto680):02595 FDB TIB-6
2602+18CA 182F (fig-forth-auto680):02596 WIDTH FDB DOUSER
2603+18CC 0024 (fig-forth-auto680):02597 FDB XWIDTH-UORIG
2604+ (fig-forth-auto680):02598 *
2605+ (fig-forth-auto680):02599 * ======>> 66 <<
2606+ (fig-forth-auto680):02600 * ( --- vadr )
2607+ (fig-forth-auto680):02601 * Availability of error messages on disk.
2608+ (fig-forth-auto680):02602 * Contains 1 if messages available,
2609+ (fig-forth-auto680):02603 * 0 if not,
2610+ (fig-forth-auto680):02604 * -1 if a disk error has occurred.
2611+18CE 87 (fig-forth-auto680):02605 FCB $87
2612+18CF 5741524E494E (fig-forth-auto680):02606 FCC 'WARNIN' ; 'WARNING'
2613+18D5 C7 (fig-forth-auto680):02607 FCB $C7
2614+18D6 18C2 (fig-forth-auto680):02608 FDB WIDTH-8
2615+18D8 182F (fig-forth-auto680):02609 WARN FDB DOUSER
2616+18DA 0026 (fig-forth-auto680):02610 FDB XWARN-UORIG
2617+ (fig-forth-auto680):02611 *
2618+ (fig-forth-auto680):02612 * ======>> 67 <<
2619+ (fig-forth-auto680):02613 * ( --- vadr )
2620+ (fig-forth-auto680):02614 * Boundary for FORGET.
2621+18DC 85 (fig-forth-auto680):02615 FCB $85
2622+18DD 46454E43 (fig-forth-auto680):02616 FCC 'FENC' ; 'FENCE'
2623+18E1 C5 (fig-forth-auto680):02617 FCB $C5
2624+18E2 18CE (fig-forth-auto680):02618 FDB WARN-10
2625+18E4 182F (fig-forth-auto680):02619 FENCE FDB DOUSER
2626+18E6 0028 (fig-forth-auto680):02620 FDB XFENCE-UORIG
2627+ (fig-forth-auto680):02621 *
2628+ (fig-forth-auto680):02622 * ======>> 68 <<
2629+ (fig-forth-auto680):02623 * ( --- vadr )
2630+ (fig-forth-auto680):02624 * Dictionary pointer, fetched by HERE.
2631+18E8 82 (fig-forth-auto680):02625 FCB $82
2632+18E9 44 (fig-forth-auto680):02626 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
2633+18EA D0 (fig-forth-auto680):02627 FCB $D0
2634+18EB 18DC (fig-forth-auto680):02628 FDB FENCE-8
2635+18ED 182F (fig-forth-auto680):02629 DICTPT FDB DOUSER
2636+18EF 002A (fig-forth-auto680):02630 FDB XDICTP-UORIG
2637+ (fig-forth-auto680):02631 *
2638+ (fig-forth-auto680):02632 * ======>> 68.5 <<
2639+ (fig-forth-auto680):02633 * ( --- vadr ) ******* Need to check what this is!
2640+ (fig-forth-auto680):02634 * Used in maintaining vocabularies.
2641+ (fig-forth-auto680):02635 * I think it points to the "parent" vocabulary, but I'm not sure.
2642+ (fig-forth-auto680):02636 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
2643+18F1 88 (fig-forth-auto680):02637 FCB $88
2644+18F2 564F432D4C494E (fig-forth-auto680):02638 FCC 'VOC-LIN' ; 'VOC-LINK'
2645+18F9 CB (fig-forth-auto680):02639 FCB $CB
2646+18FA 18E8 (fig-forth-auto680):02640 FDB DICTPT-5
2647+18FC 182F (fig-forth-auto680):02641 VOCLIN FDB DOUSER
2648+18FE 002C (fig-forth-auto680):02642 FDB XVOCL-UORIG
2649+ (fig-forth-auto680):02643 *
2650+ (fig-forth-auto680):02644 * ======>> 69 <<
2651+ (fig-forth-auto680):02645 * ( --- vadr )
2652+ (fig-forth-auto680):02646 * Disk block being interpreted.
2653+ (fig-forth-auto680):02647 * Zero refers to terminal.
2654+ (fig-forth-auto680):02648 * ******** Should be made a 32 bit user variable! ********
2655+ (fig-forth-auto680):02649 * But the base system needs to have full 32 bit support, div and mul, etc.
2656+ (fig-forth-auto680):02650 * before we can do that.
2657+1900 83 (fig-forth-auto680):02651 FCB $83
2658+1901 424C (fig-forth-auto680):02652 FCC 'BL' ; 'BLK'
2659+1903 CB (fig-forth-auto680):02653 FCB $CB
2660+1904 18F1 (fig-forth-auto680):02654 FDB VOCLIN-11
2661+1906 182F (fig-forth-auto680):02655 BLK FDB DOUSER
2662+1908 002E (fig-forth-auto680):02656 FDB XBLK-UORIG
2663+ (fig-forth-auto680):02657 *
2664+ (fig-forth-auto680):02658 * ======>> 70 <<
2665+ (fig-forth-auto680):02659 * ( --- vadr )
2666+ (fig-forth-auto680):02660 * Input buffer offset/cursor.
2667+190A 82 (fig-forth-auto680):02661 FCB $82
2668+190B 49 (fig-forth-auto680):02662 FCC 'I' ; 'IN' : scan pointer for input line buffer
2669+190C CE (fig-forth-auto680):02663 FCB $CE
2670+190D 1900 (fig-forth-auto680):02664 FDB BLK-6
2671+190F 182F (fig-forth-auto680):02665 IN FDB DOUSER
2672+1911 0030 (fig-forth-auto680):02666 FDB XIN-UORIG
2673+ (fig-forth-auto680):02667 *
2674+ (fig-forth-auto680):02668 * ======>> 71 <<
2675+ (fig-forth-auto680):02669 * ( --- vadr )
2676+ (fig-forth-auto680):02670 * Output buffer offset/cursor.
2677+1913 83 (fig-forth-auto680):02671 FCB $83
2678+1914 4F55 (fig-forth-auto680):02672 FCC 'OU' ; 'OUT'
2679+1916 D4 (fig-forth-auto680):02673 FCB $D4
2680+1917 190A (fig-forth-auto680):02674 FDB IN-5
2681+1919 182F (fig-forth-auto680):02675 OUT FDB DOUSER
2682+191B 0032 (fig-forth-auto680):02676 FDB XOUT-UORIG
2683+ (fig-forth-auto680):02677 *
2684+ (fig-forth-auto680):02678 * ======>> 72 <<
2685+ (fig-forth-auto680):02679 * ( --- vadr )
2686+ (fig-forth-auto680):02680 * Screen currently being edited, once we have an editor running.
2687+191D 83 (fig-forth-auto680):02681 FCB $83
2688+191E 5343 (fig-forth-auto680):02682 FCC 'SC' ; 'SCR'
2689+1920 D2 (fig-forth-auto680):02683 FCB $D2
2690+1921 1913 (fig-forth-auto680):02684 FDB OUT-6
2691+1923 182F (fig-forth-auto680):02685 SCR FDB DOUSER
2692+1925 0034 (fig-forth-auto680):02686 FDB XSCR-UORIG
2693+ (fig-forth-auto680):02687 * ######>> screen 37 <<
2694+ (fig-forth-auto680):02688 *
2695+ (fig-forth-auto680):02689 * ======>> 73 <<
2696+ (fig-forth-auto680):02690 * ( --- vadr )
2697+ (fig-forth-auto680):02691 * Sector offset for LOADing screens,
2698+ (fig-forth-auto680):02692 * set by DRIVE to make a new drive the default.
2699+ (fig-forth-auto680):02693 * This should also be 32 bit or bigger.
2700+1927 86 (fig-forth-auto680):02694 FCB $86
2701+1928 4F46465345 (fig-forth-auto680):02695 FCC 'OFFSE' ; 'OFFSET'
2702+192D D4 (fig-forth-auto680):02696 FCB $D4
2703+192E 191D (fig-forth-auto680):02697 FDB SCR-6
2704+1930 182F (fig-forth-auto680):02698 OFSET FDB DOUSER
2705+1932 0036 (fig-forth-auto680):02699 FDB XOFSET-UORIG
2706+ (fig-forth-auto680):02700 *
2707+ (fig-forth-auto680):02701 * ======>> 74 <<
2708+ (fig-forth-auto680):02702 * ( --- vadr )
2709+ (fig-forth-auto680):02703 * Current context of interpretation (vocabulary root).
2710+1934 87 (fig-forth-auto680):02704 FCB $87
2711+1935 434F4E544558 (fig-forth-auto680):02705 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
2712+193B D4 (fig-forth-auto680):02706 FCB $D4
2713+193C 1927 (fig-forth-auto680):02707 FDB OFSET-9
2714+193E 182F (fig-forth-auto680):02708 CONTXT FDB DOUSER
2715+1940 0038 (fig-forth-auto680):02709 FDB XCONT-UORIG
2716+ (fig-forth-auto680):02710 *
2717+ (fig-forth-auto680):02711 * ======>> 75 <<
2718+ (fig-forth-auto680):02712 * ( --- vadr )
2719+ (fig-forth-auto680):02713 * Current context of definition (vocabulary root).
2720+1942 87 (fig-forth-auto680):02714 FCB $87
2721+1943 43555252454E (fig-forth-auto680):02715 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
2722+1949 D4 (fig-forth-auto680):02716 FCB $D4
2723+194A 1934 (fig-forth-auto680):02717 FDB CONTXT-10
2724+194C 182F (fig-forth-auto680):02718 CURENT FDB DOUSER
2725+194E 003A (fig-forth-auto680):02719 FDB XCURR-UORIG
2726+ (fig-forth-auto680):02720 *
2727+ (fig-forth-auto680):02721 * ======>> 76 <<
2728+ (fig-forth-auto680):02722 * ( --- vadr )
2729+ (fig-forth-auto680):02723 * Compiler/interpreter state.
2730+1950 85 (fig-forth-auto680):02724 FCB $85
2731+1951 53544154 (fig-forth-auto680):02725 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
2732+1955 C5 (fig-forth-auto680):02726 FCB $C5
2733+1956 1942 (fig-forth-auto680):02727 FDB CURENT-10
2734+1958 182F (fig-forth-auto680):02728 STATE FDB DOUSER
2735+195A 003C (fig-forth-auto680):02729 FDB XSTATE-UORIG
2736+ (fig-forth-auto680):02730 *
2737+ (fig-forth-auto680):02731 * ======>> 77 <<
2738+ (fig-forth-auto680):02732 * ( --- vadr )
2739+ (fig-forth-auto680):02733 * Numeric conversion base.
2740+195C 84 (fig-forth-auto680):02734 FCB $84
2741+195D 424153 (fig-forth-auto680):02735 FCC 'BAS' ; 'BASE' : number base for all input & output
2742+1960 C5 (fig-forth-auto680):02736 FCB $C5
2743+1961 1950 (fig-forth-auto680):02737 FDB STATE-8
2744+1963 182F (fig-forth-auto680):02738 BASE FDB DOUSER
2745+1965 003E (fig-forth-auto680):02739 FDB XBASE-UORIG
2746+ (fig-forth-auto680):02740 *
2747+ (fig-forth-auto680):02741 * ======>> 78 <<
2748+ (fig-forth-auto680):02742 * ( --- vadr )
2749+ (fig-forth-auto680):02743 * Decimal point location for output.
2750+1967 83 (fig-forth-auto680):02744 FCB $83
2751+1968 4450 (fig-forth-auto680):02745 FCC 'DP' ; 'DPL'
2752+196A CC (fig-forth-auto680):02746 FCB $CC
2753+196B 195C (fig-forth-auto680):02747 FDB BASE-7
2754+196D 182F (fig-forth-auto680):02748 DPL FDB DOUSER
2755+196F 0040 (fig-forth-auto680):02749 FDB XDPL-UORIG
2756+ (fig-forth-auto680):02750 *
2757+ (fig-forth-auto680):02751 * ======>> 79 <<
2758+ (fig-forth-auto680):02752 * ( --- vadr )
2759+ (fig-forth-auto680):02753 * Field width for I/O formatting.
2760+1971 83 (fig-forth-auto680):02754 FCB $83
2761+1972 464C (fig-forth-auto680):02755 FCC 'FL' ; 'FLD'
2762+1974 C4 (fig-forth-auto680):02756 FCB $C4
2763+1975 1967 (fig-forth-auto680):02757 FDB DPL-6
2764+1977 182F (fig-forth-auto680):02758 FLD FDB DOUSER
2765+1979 0042 (fig-forth-auto680):02759 FDB XFLD-UORIG
2766+ (fig-forth-auto680):02760 *
2767+ (fig-forth-auto680):02761 * ======>> 80 <<
2768+ (fig-forth-auto680):02762 * ( --- vadr )
2769+ (fig-forth-auto680):02763 * Compiler stack mark for stack check.
2770+197B 83 (fig-forth-auto680):02764 FCB $83
2771+197C 4353 (fig-forth-auto680):02765 FCC 'CS' ; 'CSP'
2772+197E D0 (fig-forth-auto680):02766 FCB $D0
2773+197F 1971 (fig-forth-auto680):02767 FDB FLD-6
2774+1981 182F (fig-forth-auto680):02768 CSP FDB DOUSER
2775+1983 0044 (fig-forth-auto680):02769 FDB XCSP-UORIG
2776+ (fig-forth-auto680):02770 *
2777+ (fig-forth-auto680):02771 * ======>> 81 <<
2778+ (fig-forth-auto680):02772 * ( --- vadr )
2779+ (fig-forth-auto680):02773 * Editing cursor location.
2780+1985 82 (fig-forth-auto680):02774 FCB $82
2781+1986 52 (fig-forth-auto680):02775 FCC 'R' ; 'R#'
2782+1987 A3 (fig-forth-auto680):02776 FCB $A3
2783+1988 197B (fig-forth-auto680):02777 FDB CSP-6
2784+198A 182F (fig-forth-auto680):02778 RNUM FDB DOUSER
2785+198C 0046 (fig-forth-auto680):02779 FDB XRNUM-UORIG
2786+ (fig-forth-auto680):02780 *
2787+ (fig-forth-auto680):02781 * ======>> 82 <<
2788+ (fig-forth-auto680):02782 * ( --- vadr )
2789+ (fig-forth-auto680):02783 * Pointer to last HELD character in PAD.
2790+198E 83 (fig-forth-auto680):02784 FCB $83
2791+198F 484C (fig-forth-auto680):02785 FCC 'HL' ; 'HLD'
2792+1991 C4 (fig-forth-auto680):02786 FCB $C4
2793+1992 1985 (fig-forth-auto680):02787 FDB RNUM-5
2794+1994 17E9 (fig-forth-auto680):02788 HLD FDB DOCON
2795+1996 7C48 (fig-forth-auto680):02789 FDB XHLD
2796+ (fig-forth-auto680):02790 *
2797+ (fig-forth-auto680):02791 * ======>> 82.5 <<== SPECIAL
2798+ (fig-forth-auto680):02792 * ( --- vadr )
2799+ (fig-forth-auto680):02793 * Line width of active terminal.
2800+1998 87 (fig-forth-auto680):02794 FCB $87
2801+1999 434F4C554D4E (fig-forth-auto680):02795 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
2802+199F D3 (fig-forth-auto680):02796 FCB $D3
2803+19A0 198E (fig-forth-auto680):02797 FDB HLD-6
2804+19A2 182F (fig-forth-auto680):02798 COLUMS FDB DOUSER
2805+19A4 004C (fig-forth-auto680):02799 FDB XCOLUM-UORIG
2806+ (fig-forth-auto680):02800 *
2807+ (fig-forth-auto680):02801 * ######>> screen 38 <<
2808+ (fig-forth-auto680):02802 **
2809+ (fig-forth-auto680):02803 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
2810+ (fig-forth-auto680):02804 **
2811+ (fig-forth-auto680):02805 ** Make an INCREMENTER compiling word (not in model):
2812+ (fig-forth-auto680):02806 ** ( n --- )
2813+ (fig-forth-auto680):02807 ** { n INCREMENTER name } typical input
2814+ (fig-forth-auto680):02808 ** CREATE a header and compile the increment constant,
2815+ (fig-forth-auto680):02809 ** then overwrite the header with a call to DOINC.
2816+ (fig-forth-auto680):02810 * FCB $8B
2817+ (fig-forth-auto680):02811 * FCC 'INCREMENTE' ; 'INCREMENTER'
2818+ (fig-forth-auto680):02812 * FCB $D2
2819+ (fig-forth-auto680):02813 * FDB COLUMS-10
2820+ (fig-forth-auto680):02814 * INCR FDB DOCOL,CON,PSCODE
2821+ (fig-forth-auto680):02815 ** ( n --- ninc )
2822+ (fig-forth-auto680):02816 ** Characteristic of an INCREMENTER.
2823+ (fig-forth-auto680):02817 ** This is too naive:
2824+ (fig-forth-auto680):02818 * DOINC LDD ,U
2825+ (fig-forth-auto680):02819 * ADDD NATWID,X ; Add the increment.
2826+ (fig-forth-auto680):02820 * STD ,U
2827+ (fig-forth-auto680):02821 * RTS
2828+ (fig-forth-auto680):02822 * Compiling word should check that it is compiling a CONSTANT.
2829+ (fig-forth-auto680):02823 *
2830+ (fig-forth-auto680):02824 * ======>> 83 <<
2831+ (fig-forth-auto680):02825 * ( n --- n+1 )
2832+19A6 82 (fig-forth-auto680):02826 FCB $82
2833+19A7 31 (fig-forth-auto680):02827 FCC '1' ; '1+'
2834+19A8 AB (fig-forth-auto680):02828 FCB $AB
2835+19A9 1998 (fig-forth-auto680):02829 FDB COLUMS-10
2836+ (fig-forth-auto680):02830 * Using the model keeps things semantically connected for other processors:
2837+19AB 17B9184516C6 (fig-forth-auto680):02831 ONEP FDB DOCOL,ONE,PLUS
2838+19B1 1667 (fig-forth-auto680):02832 FDB SEMIS
2839+ (fig-forth-auto680):02833 ** Greedy alternative:
2840+ (fig-forth-auto680):02834 * ONEP FDB *+NATWID
2841+ (fig-forth-auto680):02835 * LDD ,U
2842+ (fig-forth-auto680):02836 * ADDD ONEV,PCR
2843+ (fig-forth-auto680):02837 * STD ,U
2844+ (fig-forth-auto680):02838 * RTS
2845+ (fig-forth-auto680):02839 * Naive alternative:
2846+ (fig-forth-auto680):02840 * ONEP FDB DOINC
2847+ (fig-forth-auto680):02841 * FDB 1
2848+ (fig-forth-auto680):02842 * Naive alternative:
2849+ (fig-forth-auto680):02843 * ONEP FDB *+NATWID
2850+ (fig-forth-auto680):02844 * LDD ,U
2851+ (fig-forth-auto680):02845 * ADDD #1 ; It's hard to imagine 1+ being other than 1.
2852+ (fig-forth-auto680):02846 * STD ,U
2853+ (fig-forth-auto680):02847 * RTS
2854+ (fig-forth-auto680):02848 *
2855+ (fig-forth-auto680):02849 * ======>> 84 <<
2856+ (fig-forth-auto680):02850 * ( n --- n+2 )
2857+19B3 82 (fig-forth-auto680):02851 FCB $82
2858+19B4 32 (fig-forth-auto680):02852 FCC '2' ; '2+'
2859+19B5 AB (fig-forth-auto680):02853 FCB $AB
2860+19B6 19A6 (fig-forth-auto680):02854 FDB ONEP-5
2861+ (fig-forth-auto680):02855 * Using the model keeps things semantically connected for other processors:
2862+19B8 17B9184D16C6 (fig-forth-auto680):02856 TWOP FDB DOCOL,TWO,PLUS
2863+19BE 1667 (fig-forth-auto680):02857 FDB SEMIS
2864+ (fig-forth-auto680):02858 ** Greedy alternative:
2865+ (fig-forth-auto680):02859 * TWOP FDB *+NATWID
2866+ (fig-forth-auto680):02860 * LDD ,U
2867+ (fig-forth-auto680):02861 * ADDD TWOV,PCR ; See NAT+ (NATP)
2868+ (fig-forth-auto680):02862 * STD ,U
2869+ (fig-forth-auto680):02863 * RTS
2870+ (fig-forth-auto680):02864 * Naive alternative:
2871+ (fig-forth-auto680):02865 * TWOP FDB DOINC
2872+ (fig-forth-auto680):02866 * FDB 2
2873+ (fig-forth-auto680):02867 * Naive alternative:
2874+ (fig-forth-auto680):02868 * TWOP FDB *+NATWID
2875+ (fig-forth-auto680):02869 * LDD ,U
2876+ (fig-forth-auto680):02870 * ADDD #2 ; See NAT+ (NATP)
2877+ (fig-forth-auto680):02871 * STD ,U
2878+ (fig-forth-auto680):02872 * RTS
2879+ (fig-forth-auto680):02873 *
2880+ (fig-forth-auto680):02874 * ======>> 85 <<
2881+ (fig-forth-auto680):02875 * ( --- adr )
2882+ (fig-forth-auto680):02876 * Get the DICTPT allocation, like a USER constant.
2883+ (fig-forth-auto680):02877 * Should check the stack and heap for collision.
2884+19C0 84 (fig-forth-auto680):02878 FCB $84
2885+19C1 484552 (fig-forth-auto680):02879 FCC 'HER' ; 'HERE'
2886+19C4 C5 (fig-forth-auto680):02880 FCB $C5
2887+19C5 19B3 (fig-forth-auto680):02881 FDB TWOP-5
2888+19C7 17B918ED1772 (fig-forth-auto680):02882 HERE FDB DOCOL,DICTPT,AT
2889+19CD 1667 (fig-forth-auto680):02883 FDB SEMIS
2890+ (fig-forth-auto680):02884 *
2891+ (fig-forth-auto680):02885 * ======>> 86 <<
2892+ (fig-forth-auto680):02886 * ( n --- )
2893+ (fig-forth-auto680):02887 * Increase/decrease heap (add n to DP),
2894+ (fig-forth-auto680):02888 * Should ERROR check stack/heap.
2895+19CF 85 (fig-forth-auto680):02889 FCB $85
2896+19D0 414C4C4F (fig-forth-auto680):02890 FCC 'ALLO' ; 'ALLOT'
2897+19D4 D4 (fig-forth-auto680):02891 FCB $D4
2898+19D5 19C0 (fig-forth-auto680):02892 FDB HERE-7
2899+19D7 17B918ED1751 (fig-forth-auto680):02893 ALLOT FDB DOCOL,DICTPT,PSTORE
2900+19DD 1667 (fig-forth-auto680):02894 FDB SEMIS
2901+ (fig-forth-auto680):02895 *
2902+ (fig-forth-auto680):02896 * ======>> 87 <<
2903+ (fig-forth-auto680):02897 * ( n --- )
2904+ (fig-forth-auto680):02898 * Store word n at DP++,
2905+ (fig-forth-auto680):02899 * Should ERROR check stack/heap.
2906+19DF 81 (fig-forth-auto680):02900 FCB $81 ; , (COMMA)
2907+19E0 AC (fig-forth-auto680):02901 FCB $AC
2908+19E1 19CF (fig-forth-auto680):02902 FDB ALLOT-8
2909+19E3 17B919C7178A17F7 (fig-forth-auto680):02903 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
2910+ 19D7
2911+19ED 1667 (fig-forth-auto680):02904 FDB SEMIS
2912+ (fig-forth-auto680):02905 * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
2913+ (fig-forth-auto680):02906 * FDB SEMIS
2914+ (fig-forth-auto680):02907 *
2915+ (fig-forth-auto680):02908 * ======>> 88 <<
2916+ (fig-forth-auto680):02909 * ( b --- )
2917+ (fig-forth-auto680):02910 * Store byte b at DP+,
2918+ (fig-forth-auto680):02911 * Should ERROR check stack/heap.
2919+19EF 82 (fig-forth-auto680):02912 FCB $82
2920+19F0 43 (fig-forth-auto680):02913 FCC 'C' ; 'C,'
2921+19F1 AC (fig-forth-auto680):02914 FCB $AC
2922+19F2 19DF (fig-forth-auto680):02915 FDB COMMA-4
2923+19F4 17B919C717981845 (fig-forth-auto680):02916 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
2924+ 19D7
2925+19FE 1667 (fig-forth-auto680):02917 FDB SEMIS
2926+ (fig-forth-auto680):02918 *
2927+ (fig-forth-auto680):02919 * ======>> 89 <<
2928+ (fig-forth-auto680):02920 * ( n1 n2 --- n1-n2 )
2929+ (fig-forth-auto680):02921 * Subtract top two words.
2930+1A00 81 (fig-forth-auto680):02922 FCB $81 ; -
2931+1A01 AD (fig-forth-auto680):02923 FCB $AD
2932+1A02 19EF (fig-forth-auto680):02924 FDB CCOMM-5
2933+1A04 1A06 (fig-forth-auto680):02925 SUB FDB *+NATWID
2934+1A06 EC42 (fig-forth-auto680):02926 LDD NATWID,U ; #2~6
2935+1A08 A3C1 (fig-forth-auto680):02927 SUBD ,U++ ; #2~9
2936+1A0A EDC4 (fig-forth-auto680):02928 STD ,U ; #2~5
2937+1A0C 39 (fig-forth-auto680):02929 RTS ; #1~5 = #7~25
2938+ (fig-forth-auto680):02930 * SUB FDB DOCOL,MINUS,PLUS
2939+ (fig-forth-auto680):02931 * FDB SEMIS ; Costs 6 bytes and lots of cycles.
2940+ (fig-forth-auto680):02932 *
2941+ (fig-forth-auto680):02933 * ======>> 90 <<
2942+ (fig-forth-auto680):02934 * ( n1 n2 --- n1==n2 )
2943+ (fig-forth-auto680):02935 * Return flag true if n1 and n2 are equal, otherwise false.
2944+1A0D 81 (fig-forth-auto680):02936 FCB $81 =
2945+1A0E BD (fig-forth-auto680):02937 FCB $BD
2946+1A0F 1A00 (fig-forth-auto680):02938 FDB SUB-4
2947+1A11 17B91A0416A3 (fig-forth-auto680):02939 EQUAL FDB DOCOL,SUB,ZEQU
2948+1A17 1667 (fig-forth-auto680):02940 FDB SEMIS
2949+ (fig-forth-auto680):02941 *
2950+ (fig-forth-auto680):02942 * ======>> 91 <<
2951+ (fig-forth-auto680):02943 * ( n1 n2 --- n1<n2 )
2952+ (fig-forth-auto680):02944 * Return flag true if n1 is less than n2, otherwise false.
2953+1A19 81 (fig-forth-auto680):02945 FCB $81 <
2954+1A1A BC (fig-forth-auto680):02946 FCB $BC
2955+1A1B 1A0D (fig-forth-auto680):02947 FDB EQUAL-4
2956+1A1D 1A1F (fig-forth-auto680):02948 LESS FDB *+NATWID
2957+1A1F EC42 (fig-forth-auto680):02949 LDD NATWID,U
2958+1A21 A3C1 (fig-forth-auto680):02950 SUBD ,U++
2959+1A23 2C06 (fig-forth-auto680):02951 BGE FALSE
2960+1A25 CC0001 (fig-forth-auto680):02952 TRUE LDD #1
2961+1A28 EDC4 (fig-forth-auto680):02953 STD ,U
2962+1A2A 39 (fig-forth-auto680):02954 RTS
2963+1A2B CC0000 (fig-forth-auto680):02955 FALSE LDD #0
2964+1A2E EDC4 (fig-forth-auto680):02956 STD ,U
2965+1A30 39 (fig-forth-auto680):02957 RTS
2966+ (fig-forth-auto680):02958 * PULS A ;
2967+ (fig-forth-auto680):02959 * PULS B ;
2968+ (fig-forth-auto680):02960 * TFR S,X ; TSX :
2969+ (fig-forth-auto680):02961 * CMPA 0,X
2970+ (fig-forth-auto680):02962 * LEAS 1,S ;
2971+ (fig-forth-auto680):02963 * BGT LESST
2972+ (fig-forth-auto680):02964 * BNE LESSF
2973+ (fig-forth-auto680):02965 * CMPB 1,X ; Why not sub, sbc, bge?
2974+ (fig-forth-auto680):02966 * BHI LESST
2975+ (fig-forth-auto680):02967 * LESSF CLRB ;
2976+ (fig-forth-auto680):02968 * BRA LESSX
2977+ (fig-forth-auto680):02969 * LESST LDB #1
2978+ (fig-forth-auto680):02970 * LESSX CLRA ;
2979+ (fig-forth-auto680):02971 * LEAS 1,S ;
2980+ (fig-forth-auto680):02972 * JMP PUSHBA
2981+ (fig-forth-auto680):02973 *
2982+ (fig-forth-auto680):02974 * ======>> 92 <<
2983+ (fig-forth-auto680):02975 * ( n1 n2 --- n1>n2 )
2984+ (fig-forth-auto680):02976 * Return flag true if n1 is greater than n2, false otherwise.
2985+1A31 81 (fig-forth-auto680):02977 FCB $81 >
2986+1A32 BE (fig-forth-auto680):02978 FCB $BE
2987+1A33 1A19 (fig-forth-auto680):02979 FDB LESS-4
2988+1A35 17B917361A1D (fig-forth-auto680):02980 GREAT FDB DOCOL,SWAP,LESS
2989+1A3B 1667 (fig-forth-auto680):02981 FDB SEMIS
2990+ (fig-forth-auto680):02982 *
2991+ (fig-forth-auto680):02983 * ======>> 93 <<
2992+ (fig-forth-auto680):02984 * ( n1 n2 n3 --- n2 n3 n1 )
2993+ (fig-forth-auto680):02985 * Rotate the top three words on stack,
2994+ (fig-forth-auto680):02986 * bringing the third word to the top.
2995+1A3D 83 (fig-forth-auto680):02987 FCB $83
2996+1A3E 524F (fig-forth-auto680):02988 FCC 'RO' ; 'ROT'
2997+1A40 D4 (fig-forth-auto680):02989 FCB $D4
2998+1A41 1A31 (fig-forth-auto680):02990 FDB GREAT-4
2999+1A43 1A45 (fig-forth-auto680):02991 ROT FDB *+NATWID
3000+1A45 3420 (fig-forth-auto680):02992 PSHS Y
3001+1A47 3736 (fig-forth-auto680):02993 PULU D,X,Y
3002+1A49 3616 (fig-forth-auto680):02994 PSHU D,X
3003+1A4B 3620 (fig-forth-auto680):02995 PSHU Y
3004+1A4D 35A0 (fig-forth-auto680):02996 PULS Y,PC
3005+ (fig-forth-auto680):02997 * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
3006+ (fig-forth-auto680):02998 * FDB SEMIS
3007+ (fig-forth-auto680):02999 *
3008+ (fig-forth-auto680):03000 * ======>> 94 <<
3009+ (fig-forth-auto680):03001 * ( --- )
3010+ (fig-forth-auto680):03002 * EMIT a SPACE.
3011+1A4F 85 (fig-forth-auto680):03003 FCB $85
3012+1A50 53504143 (fig-forth-auto680):03004 FCC 'SPAC' ; 'SPACE'
3013+1A54 C5 (fig-forth-auto680):03005 FCB $C5
3014+1A55 1A3D (fig-forth-auto680):03006 FDB ROT-6
3015+1A57 17B9185E1542 (fig-forth-auto680):03007 SPACE FDB DOCOL,BL,EMIT
3016+1A5D 1667 (fig-forth-auto680):03008 FDB SEMIS
3017+ (fig-forth-auto680):03009 *
3018+ (fig-forth-auto680):03010 * ======>> 95 <<
3019+ (fig-forth-auto680):03011 * ( n0 n1 --- min(n0,n1) )
3020+ (fig-forth-auto680):03012 * Leave the minimum of the top two integers.
3021+ (fig-forth-auto680):03013 * Being too greedy here, but, whatever.
3022+1A5F 83 (fig-forth-auto680):03014 FCB $83
3023+1A60 4D49 (fig-forth-auto680):03015 FCC 'MI' ; 'MIN'
3024+1A62 CE (fig-forth-auto680):03016 FCB $CE
3025+1A63 1A4F (fig-forth-auto680):03017 FDB SPACE-8
3026+1A65 1A67 (fig-forth-auto680):03018 MIN FDB *+NATWID
3027+1A67 3706 (fig-forth-auto680):03019 PULU D
3028+1A69 10A3C4 (fig-forth-auto680):03020 CMPD ,U
3029+1A6C 2F02 (fig-forth-auto680):03021 BLE MINX
3030+1A6E EDC4 (fig-forth-auto680):03022 STD ,U
3031+1A70 39 (fig-forth-auto680):03023 MINX RTS
3032+ (fig-forth-auto680):03024 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
3033+ (fig-forth-auto680):03025 * FDB MIN2-*-NATWID
3034+ (fig-forth-auto680):03026 * FDB SWAP
3035+ (fig-forth-auto680):03027 * MIN2 FDB DROP
3036+ (fig-forth-auto680):03028 * FDB SEMIS
3037+ (fig-forth-auto680):03029 *
3038+ (fig-forth-auto680):03030 * ======>> 96 <<
3039+ (fig-forth-auto680):03031 * ( n0 n1 --- max(n0,n1) )
3040+ (fig-forth-auto680):03032 * Leave the maximum of the top two integers.
3041+ (fig-forth-auto680):03033 * Really should leave this as in the model.
3042+1A71 83 (fig-forth-auto680):03034 FCB $83
3043+1A72 4D41 (fig-forth-auto680):03035 FCC 'MA' ; 'MAX'
3044+1A74 D8 (fig-forth-auto680):03036 FCB $D8
3045+1A75 1A5F (fig-forth-auto680):03037 FDB MIN-6
3046+1A77 1A79 (fig-forth-auto680):03038 MAX FDB *+NATWID
3047+1A79 3706 (fig-forth-auto680):03039 PULU D
3048+1A7B 10A3C4 (fig-forth-auto680):03040 CMPD ,U
3049+1A7E 2F02 (fig-forth-auto680):03041 BLE MAXX
3050+1A80 EDC4 (fig-forth-auto680):03042 STD ,U
3051+1A82 39 (fig-forth-auto680):03043 MAXX RTS
3052+ (fig-forth-auto680):03044 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
3053+ (fig-forth-auto680):03045 * FDB MAX2-*-NATWID
3054+ (fig-forth-auto680):03046 * FDB SWAP
3055+ (fig-forth-auto680):03047 * MAX2 FDB DROP
3056+ (fig-forth-auto680):03048 * FDB SEMIS
3057+ (fig-forth-auto680):03049 *
3058+ (fig-forth-auto680):03050 * ======>> 97 <<
3059+ (fig-forth-auto680):03051 * ( 0 --- 0 )
3060+ (fig-forth-auto680):03052 * ( n --- n n )
3061+ (fig-forth-auto680):03053 * DUP if non-zero.
3062+1A83 84 (fig-forth-auto680):03054 FCB $84
3063+1A84 2D4455 (fig-forth-auto680):03055 FCC '-DU' ; '-DUP'
3064+1A87 D0 (fig-forth-auto680):03056 FCB $D0
3065+1A88 1A71 (fig-forth-auto680):03057 FDB MAX-6
3066+1A8A 1A8C (fig-forth-auto680):03058 DDUP FDB *+NATWID
3067+1A8C ECC4 (fig-forth-auto680):03059 LDD ,U
3068+1A8E 2702 (fig-forth-auto680):03060 BEQ DDUPX
3069+1A90 3606 (fig-forth-auto680):03061 PSHU D
3070+1A92 39 (fig-forth-auto680):03062 DDUPX RTS
3071+ (fig-forth-auto680):03063 * DDUP FDB DOCOL,DUP,ZBRAN
3072+ (fig-forth-auto680):03064 * FDB DDUP2-*-NATWID
3073+ (fig-forth-auto680):03065 * FDB DUP
3074+ (fig-forth-auto680):03066 * DDUP2 FDB SEMIS
3075+ (fig-forth-auto680):03067 *
3076+ (fig-forth-auto680):03068 * ######>> screen 39 <<
3077+ (fig-forth-auto680):03069 * ======>> 98.1 <<
3078+ (fig-forth-auto680):03070 * Supplemental:
3079+ (fig-forth-auto680):03071 * ( n<0 --- -1 )
3080+ (fig-forth-auto680):03072 * ( n>=~ --- 1 )
3081+ (fig-forth-auto680):03073 * Change top integer to its sign.
3082+1A93 86 (fig-forth-auto680):03074 FCB $86
3083+1A94 5349474E55 (fig-forth-auto680):03075 FCC 'SIGNU' ; 'SIGNUM'
3084+1A99 CD (fig-forth-auto680):03076 FCB $CD
3085+1A9A 1A83 (fig-forth-auto680):03077 FDB DDUP-7
3086+1A9C 1A9E (fig-forth-auto680):03078 SIGNUM FDB *+NATWID
3087+1A9E C601 (fig-forth-auto680):03079 SIGNUE LDB #1
3088+1AA0 A6C4 (fig-forth-auto680):03080 LDA ,U
3089+1AA2 2A01 (fig-forth-auto680):03081 BPL SIGNUP
3090+1AA4 50 (fig-forth-auto680):03082 NEGB
3091+1AA5 1D (fig-forth-auto680):03083 SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
3092+1AA6 EDC4 (fig-forth-auto680):03084 STD ,U ; Am I too much of a prude?
3093+1AA8 39 (fig-forth-auto680):03085 RTS
3094+ (fig-forth-auto680):03086 * 6800 model version should be something like this:
3095+ (fig-forth-auto680):03087 * LDB #1
3096+ (fig-forth-auto680):03088 * CLRA
3097+ (fig-forth-auto680):03089 * TSX
3098+ (fig-forth-auto680):03090 * TST ,X
3099+ (fig-forth-auto680):03091 * BPL SIGNUP
3100+ (fig-forth-auto680):03092 * NEGB
3101+ (fig-forth-auto680):03093 * COMA
3102+ (fig-forth-auto680):03094 * SIGNUP JMP STABX
3103+ (fig-forth-auto680):03095 *
3104+ (fig-forth-auto680):03096 * ======>> 98 <<
3105+ (fig-forth-auto680):03097 * ( adr1 direction --- adr2 )
3106+ (fig-forth-auto680):03098 * TRAVERSE the symbol name.
3107+ (fig-forth-auto680):03099 * If direction is 1, find the end.
3108+ (fig-forth-auto680):03100 * If direction is -1, find the beginning.
3109+1AA9 88 (fig-forth-auto680):03101 FCB $88
3110+1AAA 54524156455253 (fig-forth-auto680):03102 FCC 'TRAVERS' ; 'TRAVERSE'
3111+1AB1 C5 (fig-forth-auto680):03103 FCB $C5
3112+1AB2 1A93 (fig-forth-auto680):03104 FDB SIGNUM-9
3113+1AB4 1AB6 (fig-forth-auto680):03105 TRAV FDB *+NATWID
3114+1AB6 8DE6 (fig-forth-auto680):03106 BSR SIGNUE ; Convert negative to -, zero or positive to 1.
3115+1AB8 ECC1 (fig-forth-auto680):03107 LDD ,U++ ; Still in D, but we have to pop it anyway.
3116+1ABA AEC4 (fig-forth-auto680):03108 LDX ,U ; If D is 1 or -1, so is B.
3117+1ABC 867F (fig-forth-auto680):03109 LDA #$7F
3118+1ABE 3085 (fig-forth-auto680):03110 TRAVLP LEAX B,X ; Don't look at the one we start at.
3119+1AC0 A184 (fig-forth-auto680):03111 CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
3120+1AC2 24FA (fig-forth-auto680):03112 BCC TRAVLP
3121+1AC4 AFC4 (fig-forth-auto680):03113 TRAVDN STX ,U
3122+1AC6 39 (fig-forth-auto680):03114 RTS
3123+ (fig-forth-auto680):03115 * Doing this in 6809 just because it can be done may be getting too greedy.
3124+ (fig-forth-auto680):03116 * TRAV FDB DOCOL,SWAP
3125+ (fig-forth-auto680):03117 * TRAV2 FDB OVER,PLUS,LIT8
3126+ (fig-forth-auto680):03118 * FCB $7F
3127+ (fig-forth-auto680):03119 * FDB OVER,CAT,LESS,ZBRAN
3128+ (fig-forth-auto680):03120 * FDB TRAV2-*-NATWID
3129+ (fig-forth-auto680):03121 * FDB SWAP,DROP
3130+ (fig-forth-auto680):03122 * FDB SEMIS
3131+ (fig-forth-auto680):03123 *
3132+ (fig-forth-auto680):03124 * ======>> 99 <<
3133+ (fig-forth-auto680):03125 * ( --- symptr )
3134+ (fig-forth-auto680):03126 * Fetch CURRENT as a per-USER constant.
3135+1AC7 86 (fig-forth-auto680):03127 FCB $86
3136+1AC8 4C41544553 (fig-forth-auto680):03128 FCC 'LATES' ; 'LATEST'
3137+1ACD D4 (fig-forth-auto680):03129 FCB $D4
3138+1ACE 1AA9 (fig-forth-auto680):03130 FDB TRAV-11
3139+1AD0 17B9194C17721772 (fig-forth-auto680):03131 LATEST FDB DOCOL,CURENT,AT,AT
3140+1AD8 1667 (fig-forth-auto680):03132 FDB SEMIS
3141+ (fig-forth-auto680):03133 * LATEST FDB *+NATWID
3142+ (fig-forth-auto680):03134 * Getting too greedy:
3143+ (fig-forth-auto680):03135 * Version 1:
3144+ (fig-forth-auto680):03136 * TFR DP,A
3145+ (fig-forth-auto680):03137 * CLRB
3146+ (fig-forth-auto680):03138 * TFR D,X
3147+ (fig-forth-auto680):03139 * LDD CURENT+NATWID,PCR
3148+ (fig-forth-auto680):03140 * LDX [D,X]
3149+ (fig-forth-auto680):03141 * PSHU X ; Leave the address in X.
3150+ (fig-forth-auto680):03142 * RTS
3151+ (fig-forth-auto680):03143 * Version 2:
3152+ (fig-forth-auto680):03144 * LEAX CURENT,PCR
3153+ (fig-forth-auto680):03145 * JSR [,X]
3154+ (fig-forth-auto680):03146 * PULU X
3155+ (fig-forth-auto680):03147 * LDX [,X]
3156+ (fig-forth-auto680):03148 * PSHU X
3157+ (fig-forth-auto680):03149 * RTS
3158+ (fig-forth-auto680):03150 * Too greedy, too many smantic holes to fall through.
3159+ (fig-forth-auto680):03151 * If the address at the CFA is made relative,
3160+ (fig-forth-auto680):03152 * this is part of the code that would be affected
3161+ (fig-forth-auto680):03153 * if it is in native CPU code.
3162+ (fig-forth-auto680):03154 *
3163+ (fig-forth-auto680):03155 * ======>> 100 <<
3164+ (fig-forth-auto680):03156 * Wanted to do these as INCREMENTERs,
3165+ (fig-forth-auto680):03157 * but I need to stick with the model as much as possible,
3166+ (fig-forth-auto680):03158 * (mostly, LOL) adding code only to make the model more clear.
3167+ (fig-forth-auto680):03159 * ( pfa --- lfa )
3168+ (fig-forth-auto680):03160 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
3169+1ADA 83 (fig-forth-auto680):03161 FCB $83
3170+1ADB 4C46 (fig-forth-auto680):03162 FCC 'LF' ; 'LFA'
3171+1ADD C1 (fig-forth-auto680):03163 FCB $C1
3172+1ADE 1AC7 (fig-forth-auto680):03164 FDB LATEST-9
3173+1AE0 17B913A7 (fig-forth-auto680):03165 LFA FDB DOCOL,LIT8
3174+ (fig-forth-auto680):03166 * FCB 4
3175+1AE4 04 (fig-forth-auto680):03167 FCB 2*NATWID
3176+1AE5 1A04 (fig-forth-auto680):03168 FDB SUB
3177+1AE7 1667 (fig-forth-auto680):03169 FDB SEMIS
3178+ (fig-forth-auto680):03170 *
3179+ (fig-forth-auto680):03171 * ======>> 101 <<
3180+ (fig-forth-auto680):03172 * ( pfa --- cfa )
3181+ (fig-forth-auto680):03173 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
3182+1AE9 83 (fig-forth-auto680):03174 FCB $83
3183+1AEA 4346 (fig-forth-auto680):03175 FCC 'CF' ; 'CFA'
3184+1AEC C1 (fig-forth-auto680):03176 FCB $C1
3185+1AED 1ADA (fig-forth-auto680):03177 FDB LFA-6
3186+ (fig-forth-auto680):03178 * CFA FDB DOCOL,TWO,SUB
3187+1AEF 17B917F71A04 (fig-forth-auto680):03179 CFA FDB DOCOL,NATWC,SUB
3188+1AF5 1667 (fig-forth-auto680):03180 FDB SEMIS
3189+ (fig-forth-auto680):03181 *
3190+ (fig-forth-auto680):03182 * ======>> 102 <<
3191+ (fig-forth-auto680):03183 * ( pfa --- nfa )
3192+ (fig-forth-auto680):03184 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
3193+1AF7 83 (fig-forth-auto680):03185 FCB $83
3194+1AF8 4E46 (fig-forth-auto680):03186 FCC 'NF' ; 'NFA'
3195+1AFA C1 (fig-forth-auto680):03187 FCB $C1
3196+1AFB 1AE9 (fig-forth-auto680):03188 FDB CFA-6
3197+1AFD 17B913A7 (fig-forth-auto680):03189 NFA FDB DOCOL,LIT8
3198+ (fig-forth-auto680):03190 * FCB 5
3199+1B01 05 (fig-forth-auto680):03191 FCB NATWID*2+1
3200+1B02 1A04184516EF1AB4 (fig-forth-auto680):03192 FDB SUB,ONE,MINUS,TRAV
3201+1B0A 1667 (fig-forth-auto680):03193 FDB SEMIS
3202+ (fig-forth-auto680):03194 *
3203+ (fig-forth-auto680):03195 * ======>> 103 <<
3204+ (fig-forth-auto680):03196 * ( nfa --- pfa )
3205+ (fig-forth-auto680):03197 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
3206+1B0C 83 (fig-forth-auto680):03198 FCB $83
3207+1B0D 5046 (fig-forth-auto680):03199 FCC 'PF' ; 'PFA'
3208+1B0F C1 (fig-forth-auto680):03200 FCB $C1
3209+1B10 1AF7 (fig-forth-auto680):03201 FDB NFA-6
3210+1B12 17B918451AB413A7 (fig-forth-auto680):03202 PFA FDB DOCOL,ONE,TRAV,LIT8
3211+ (fig-forth-auto680):03203 * FCB 5
3212+1B1A 05 (fig-forth-auto680):03204 FCB NATWID*2+1
3213+1B1B 16C6 (fig-forth-auto680):03205 FDB PLUS
3214+1B1D 1667 (fig-forth-auto680):03206 FDB SEMIS
3215+ (fig-forth-auto680):03207 *
3216+ (fig-forth-auto680):03208 * ######>> screen 40 <<
3217+ (fig-forth-auto680):03209 * ======>> 104 <<
3218+ (fig-forth-auto680):03210 * ( --- )
3219+ (fig-forth-auto680):03211 * Save the parameter stack pointer in CSP for compiler checks.
3220+1B1F 84 (fig-forth-auto680):03212 FCB $84
3221+1B20 214353 (fig-forth-auto680):03213 FCC '!CS' ; '!CSP'
3222+1B23 D0 (fig-forth-auto680):03214 FCB $D0
3223+1B24 1B0C (fig-forth-auto680):03215 FDB PFA-6
3224+1B26 17B916401981178A (fig-forth-auto680):03216 SCSP FDB DOCOL,SPAT,CSP,STORE
3225+1B2E 1667 (fig-forth-auto680):03217 FDB SEMIS
3226+ (fig-forth-auto680):03218 *
3227+ (fig-forth-auto680):03219 * ======>> 105 <<
3228+ (fig-forth-auto680):03220 * ( 0 n --- ) ( *** )
3229+ (fig-forth-auto680):03221 * ( true n --- IN BLK ) ( anything *** nothing )
3230+ (fig-forth-auto680):03222 * If flag is false, do nothing.
3231+ (fig-forth-auto680):03223 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
3232+ (fig-forth-auto680):03224 * Leaves cursor position (IN)
3233+ (fig-forth-auto680):03225 * and currently loading block number (BLK) on stack, for analysis.
3234+ (fig-forth-auto680):03226 *
3235+ (fig-forth-auto680):03227 * This one is too important to be high-level Forth codes.
3236+ (fig-forth-auto680):03228 * When we have an error, we want to disturb as little as possible.
3237+ (fig-forth-auto680):03229 * But fixing that cascades through ERROR and MESSAGE
3238+ (fig-forth-auto680):03230 * into the disk block system.
3239+ (fig-forth-auto680):03231 * And we aren't ready for that yet.
3240+1B30 86 (fig-forth-auto680):03232 FCB $86
3241+1B31 3F4552524F (fig-forth-auto680):03233 FCC '?ERRO' ; '?ERROR'
3242+1B36 D2 (fig-forth-auto680):03234 FCB $D2
3243+1B37 1B1F (fig-forth-auto680):03235 FDB SCSP-7
3244+ (fig-forth-auto680):03236 * QERR FDB *+NATWID
3245+ (fig-forth-auto680):03237 * LDD NATWID,U
3246+ (fig-forth-auto680):03238 * BNE QERROR
3247+ (fig-forth-auto680):03239 * LEAU 2*NATWID,U
3248+ (fig-forth-auto680):03240 * RTS
3249+ (fig-forth-auto680):03241 ** this doesn't work anyway: QERROR LBR ERROR
3250+1B39 17B917361409 (fig-forth-auto680):03242 QERR FDB DOCOL,SWAP,ZBRAN
3251+1B3F 0006 (fig-forth-auto680):03243 FDB QERR2-*-NATWID
3252+1B41 1FE713FA (fig-forth-auto680):03244 FDB ERROR,BRAN
3253+1B45 0002 (fig-forth-auto680):03245 FDB QERR3-*-NATWID
3254+1B47 172A (fig-forth-auto680):03246 QERR2 FDB DROP
3255+1B49 1667 (fig-forth-auto680):03247 QERR3 FDB SEMIS
3256+ (fig-forth-auto680):03248 *
3257+ (fig-forth-auto680):03249 * ======>> 106 <<
3258+ (fig-forth-auto680):03250 * STATE is compiling:
3259+ (fig-forth-auto680):03251 * ( --- ) ( *** )
3260+ (fig-forth-auto680):03252 * STATE is compiling:
3261+ (fig-forth-auto680):03253 * ( --- IN BLK ) ( anything *** nothing )
3262+ (fig-forth-auto680):03254 * ERROR if not compiling.
3263+1B4B 85 (fig-forth-auto680):03255 FCB $85
3264+1B4C 3F434F4D (fig-forth-auto680):03256 FCC '?COM' ; '?COMP'
3265+1B50 D0 (fig-forth-auto680):03257 FCB $D0
3266+1B51 1B30 (fig-forth-auto680):03258 FDB QERR-9
3267+1B53 17B91958177216A3 (fig-forth-auto680):03259 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
3268+ 13A7
3269+1B5D 11 (fig-forth-auto680):03260 FCB $11
3270+1B5E 1B39 (fig-forth-auto680):03261 FDB QERR
3271+1B60 1667 (fig-forth-auto680):03262 FDB SEMIS
3272+ (fig-forth-auto680):03263 *
3273+ (fig-forth-auto680):03264 * ======>> 107 <<
3274+ (fig-forth-auto680):03265 * STATE is executing:
3275+ (fig-forth-auto680):03266 * ( --- ) ( *** )
3276+ (fig-forth-auto680):03267 * STATE is executing:
3277+ (fig-forth-auto680):03268 * ( --- IN BLK ) ( anything *** nothing )
3278+ (fig-forth-auto680):03269 * ERROR if not executing.
3279+1B62 85 (fig-forth-auto680):03270 FCB $85
3280+1B63 3F455845 (fig-forth-auto680):03271 FCC '?EXE' ; '?EXEC'
3281+1B67 C3 (fig-forth-auto680):03272 FCB $C3
3282+1B68 1B4B (fig-forth-auto680):03273 FDB QCOMP-8
3283+1B6A 17B91958177213A7 (fig-forth-auto680):03274 QEXEC FDB DOCOL,STATE,AT,LIT8
3284+1B72 12 (fig-forth-auto680):03275 FCB $12
3285+1B73 1B39 (fig-forth-auto680):03276 FDB QERR
3286+1B75 1667 (fig-forth-auto680):03277 FDB SEMIS
3287+ (fig-forth-auto680):03278 *
3288+ (fig-forth-auto680):03279 * ======>> 108 <<
3289+ (fig-forth-auto680):03280 * ( n1 n1 --- ) ( *** )
3290+ (fig-forth-auto680):03281 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
3291+ (fig-forth-auto680):03282 * ERROR if top two are unequal.
3292+ (fig-forth-auto680):03283 * MESSAGE says compiled conditionals do not match.
3293+1B77 86 (fig-forth-auto680):03284 FCB $86
3294+1B78 3F50414952 (fig-forth-auto680):03285 FCC '?PAIR' ; '?PAIRS'
3295+1B7D D3 (fig-forth-auto680):03286 FCB $D3
3296+1B7E 1B62 (fig-forth-auto680):03287 FDB QEXEC-8
3297+1B80 17B91A0413A7 (fig-forth-auto680):03288 QPAIRS FDB DOCOL,SUB,LIT8
3298+1B86 13 (fig-forth-auto680):03289 FCB $13
3299+1B87 1B39 (fig-forth-auto680):03290 FDB QERR
3300+1B89 1667 (fig-forth-auto680):03291 FDB SEMIS
3301+ (fig-forth-auto680):03292 *
3302+ (fig-forth-auto680):03293 * ======>> 109 <<
3303+ (fig-forth-auto680):03294 * CSP and parameter stack are balanced (equal):
3304+ (fig-forth-auto680):03295 * ( --- ) ( *** )
3305+ (fig-forth-auto680):03296 * CSP and parameter stack are not balanced (unequal):
3306+ (fig-forth-auto680):03297 * ( --- IN BLK ) ( anything *** nothing )
3307+ (fig-forth-auto680):03298 * ERROR if return/control stack is not at same level as last !CSP.
3308+ (fig-forth-auto680):03299 * Usually indicates that a definition has been left incomplete.
3309+1B8B 84 (fig-forth-auto680):03300 FCB $84
3310+1B8C 3F4353 (fig-forth-auto680):03301 FCC '?CS' ; '?CSP'
3311+1B8F D0 (fig-forth-auto680):03302 FCB $D0
3312+1B90 1B77 (fig-forth-auto680):03303 FDB QPAIRS-9
3313+1B92 17B9164019811772 (fig-forth-auto680):03304 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
3314+ 1A0413A7
3315+1B9E 14 (fig-forth-auto680):03305 FCB $14
3316+1B9F 1B39 (fig-forth-auto680):03306 FDB QERR
3317+1BA1 1667 (fig-forth-auto680):03307 FDB SEMIS
3318+ (fig-forth-auto680):03308 *
3319+ (fig-forth-auto680):03309 * ======>> 110 <<
3320+ (fig-forth-auto680):03310 * Active BLK input:
3321+ (fig-forth-auto680):03311 * ( --- ) ( *** )
3322+ (fig-forth-auto680):03312 * No active BLK input:
3323+ (fig-forth-auto680):03313 * ( --- IN BLK ) ( anything *** nothing )
3324+ (fig-forth-auto680):03314 * ERROR if not loading, i. e., if BLK is zero.
3325+1BA3 88 (fig-forth-auto680):03315 FCB $88
3326+1BA4 3F4C4F4144494E (fig-forth-auto680):03316 FCC '?LOADIN' ; '?LOADING'
3327+1BAB C7 (fig-forth-auto680):03317 FCB $C7
3328+1BAC 1B8B (fig-forth-auto680):03318 FDB QCSP-7
3329+1BAE 17B91906177216A3 (fig-forth-auto680):03319 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
3330+ 13A7
3331+1BB8 16 (fig-forth-auto680):03320 FCB $16
3332+1BB9 1B39 (fig-forth-auto680):03321 FDB QERR
3333+1BBB 1667 (fig-forth-auto680):03322 FDB SEMIS
3334+ (fig-forth-auto680):03323 *
3335+ (fig-forth-auto680):03324 * ######>> screen 41 <<
3336+ (fig-forth-auto680):03325 * ======>> 111 <<
3337+ (fig-forth-auto680):03326 * ( --- )
3338+ (fig-forth-auto680):03327 * Compile an in-line literal value from the instruction stream.
3339+1BBD 87 (fig-forth-auto680):03328 FCB $87
3340+1BBE 434F4D50494C (fig-forth-auto680):03329 FCC 'COMPIL' ; 'COMPILE'
3341+1BC4 C5 (fig-forth-auto680):03330 FCB $C5
3342+1BC5 1BA3 (fig-forth-auto680):03331 FDB QLOAD-11
3343+ (fig-forth-auto680):03332 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
3344+ (fig-forth-auto680):03333 * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3345+1BC7 17B91B5316901745 (fig-forth-auto680):03334 COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
3346+ 18021681177219E3
3347+1BD7 1667 (fig-forth-auto680):03335 FDB SEMIS
3348+ (fig-forth-auto680):03336 *
3349+ (fig-forth-auto680):03337 * ======>> 112 <<
3350+ (fig-forth-auto680):03338 * ( --- ) P
3351+ (fig-forth-auto680):03339 * Clear the compile state bit(s) (shift to interpret).
3352+1BD9 C1 (fig-forth-auto680):03340 FCB $C1 [ immediate
3353+1BDA DB (fig-forth-auto680):03341 FCB $DB
3354+1BDB 1BBD (fig-forth-auto680):03342 FDB COMPIL-10
3355+1BDD 17B9183D1958178A (fig-forth-auto680):03343 LBRAK FDB DOCOL,ZERO,STATE,STORE
3356+1BE5 1667 (fig-forth-auto680):03344 FDB SEMIS
3357+ (fig-forth-auto680):03345 *
3358+ (fig-forth-auto680):03346 * ======>> 113 <<
3359+ (fig-forth-auto680):03347 *
3360+ 00C0 (fig-forth-auto680):03348 STCOMP EQU $C0
3361+ (fig-forth-auto680):03349 * ( --- )
3362+ (fig-forth-auto680):03350 * Set the compile state bit(s) (shift to compile).
3363+1BE7 81 (fig-forth-auto680):03351 FCB $81 ]
3364+1BE8 DD (fig-forth-auto680):03352 FCB $DD
3365+1BE9 1BD9 (fig-forth-auto680):03353 FDB LBRAK-4
3366+1BEB 17B913A7 (fig-forth-auto680):03354 RBRAK FDB DOCOL,LIT8
3367+1BEF C0 (fig-forth-auto680):03355 FCB STCOMP
3368+1BF0 1958178A (fig-forth-auto680):03356 FDB STATE,STORE
3369+1BF4 1667 (fig-forth-auto680):03357 FDB SEMIS
3370+ (fig-forth-auto680):03358 *
3371+ (fig-forth-auto680):03359 * ======>> 114 <<
3372+ (fig-forth-auto680):03360 * ( --- )
3373+ (fig-forth-auto680):03361 * Toggle SMUDGE bit of LATEST definition header,
3374+ (fig-forth-auto680):03362 * to hide it until defined or reveal it after definition.
3375+1BF6 86 (fig-forth-auto680):03363 FCB $86
3376+1BF7 534D554447 (fig-forth-auto680):03364 FCC 'SMUDG' ; 'SMUDGE'
3377+1BFC C5 (fig-forth-auto680):03365 FCB $C5
3378+1BFD 1BE7 (fig-forth-auto680):03366 FDB RBRAK-4
3379+1BFF 17B91AD013A7 (fig-forth-auto680):03367 SMUDGE FDB DOCOL,LATEST,LIT8
3380+1C05 20 (fig-forth-auto680):03368 FCB FSMUDG
3381+1C06 1765 (fig-forth-auto680):03369 FDB TOGGLE
3382+1C08 1667 (fig-forth-auto680):03370 FDB SEMIS
3383+ (fig-forth-auto680):03371 *
3384+ (fig-forth-auto680):03372 * ======>> 115 <<
3385+ (fig-forth-auto680):03373 * ( --- )
3386+ (fig-forth-auto680):03374 * Set the conversion base to sixteen (b00010000).
3387+1C0A 83 (fig-forth-auto680):03375 FCB $83
3388+1C0B 4845 (fig-forth-auto680):03376 FCC 'HE' ; 'HEX'
3389+1C0D D8 (fig-forth-auto680):03377 FCB $D8
3390+1C0E 1BF6 (fig-forth-auto680):03378 FDB SMUDGE-9
3391+1C10 17B9 (fig-forth-auto680):03379 HEX FDB DOCOL
3392+1C12 13A7 (fig-forth-auto680):03380 FDB LIT8
3393+1C14 10 (fig-forth-auto680):03381 FCB 16 ; decimal sixteen
3394+1C15 1963178A (fig-forth-auto680):03382 FDB BASE,STORE
3395+1C19 1667 (fig-forth-auto680):03383 FDB SEMIS
3396+ (fig-forth-auto680):03384 *
3397+ (fig-forth-auto680):03385 * ======>> 116 <<
3398+ (fig-forth-auto680):03386 * ( --- )
3399+ (fig-forth-auto680):03387 * Set the conversion base to ten (b00001010).
3400+1C1B 87 (fig-forth-auto680):03388 FCB $87
3401+1C1C 444543494D41 (fig-forth-auto680):03389 FCC 'DECIMA' ; 'DECIMAL'
3402+1C22 CC (fig-forth-auto680):03390 FCB $CC
3403+1C23 1C0A (fig-forth-auto680):03391 FDB HEX-6
3404+1C25 17B9 (fig-forth-auto680):03392 DEC FDB DOCOL
3405+1C27 13A7 (fig-forth-auto680):03393 FDB LIT8
3406+1C29 0A (fig-forth-auto680):03394 FCB 10 ; decimal ten
3407+1C2A 1963178A (fig-forth-auto680):03395 FDB BASE,STORE
3408+1C2E 1667 (fig-forth-auto680):03396 FDB SEMIS
3409+ (fig-forth-auto680):03397 *
3410+ (fig-forth-auto680):03398 * ######>> screen 42 <<
3411+ (fig-forth-auto680):03399 * ======>> 117 <<
3412+ (fig-forth-auto680):03400 * ( --- ) ( IP *** )
3413+ (fig-forth-auto680):03401 * Pop the saved IP and use it to
3414+ (fig-forth-auto680):03402 * compile the latest symbol as a reference to a ;CODE definition;
3415+ (fig-forth-auto680):03403 * overwrite the code field of the symbol found by LATEST
3416+ (fig-forth-auto680):03404 * with the address of the low-level characteristic code
3417+ (fig-forth-auto680):03405 * provided in the defining definition.
3418+ (fig-forth-auto680):03406 * Look closely at where things return, consider the operation of R> and >R .
3419+ (fig-forth-auto680):03407 *
3420+ (fig-forth-auto680):03408 * The machine-level code which follows (;CODE) in the instruction stream
3421+ (fig-forth-auto680):03409 * is not executed by the defining symbol,
3422+ (fig-forth-auto680):03410 * but becomes the characteristic of the defined symbol.
3423+ (fig-forth-auto680):03411 * This is the usual way to generate the characteristics of VARIABLEs,
3424+ (fig-forth-auto680):03412 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
3425+ (fig-forth-auto680):03413 *
3426+ (fig-forth-auto680):03414 * Finally, note that, if code shifts from low level back to high
3427+ (fig-forth-auto680):03415 * (native CPU machine code calling into a list of FORTH codes),
3428+ (fig-forth-auto680):03416 * the low level code can't just call a high-level definition.
3429+ (fig-forth-auto680):03417 * Leaf definitions can directly call other leaf definitions,
3430+ (fig-forth-auto680):03418 * but not non-leafs.
3431+ (fig-forth-auto680):03419 * It will need an anonymous list, probably embedded in the low-level code,
3432+ (fig-forth-auto680):03420 * and Y and X will have to be set appropriately before entering the list.
3433+1C30 87 (fig-forth-auto680):03421 FCB $87
3434+1C31 283B434F4445 (fig-forth-auto680):03422 FCC '(;CODE' ; '(;CODE)'
3435+1C37 A9 (fig-forth-auto680):03423 FCB $A9
3436+1C38 1C1B (fig-forth-auto680):03424 FDB DEC-10
3437+ (fig-forth-auto680):03425 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
3438+1C3A 17B91690 (fig-forth-auto680):03426 PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
3439+1C3E 1AD01B121AEF178A (fig-forth-auto680):03427 FDB LATEST,PFA,CFA,STORE
3440+1C46 1667 (fig-forth-auto680):03428 FDB SEMIS
3441+ (fig-forth-auto680):03429 *
3442+ (fig-forth-auto680):03430 * ======>> 118 <<
3443+ (fig-forth-auto680):03431 * ( --- ) P
3444+ (fig-forth-auto680):03432 * ?CSP to see if there are loose ends in the defining definition
3445+ (fig-forth-auto680):03433 * before shifting to the assembler,
3446+ (fig-forth-auto680):03434 * compile (;CODE) in the defining definition's instruction stream,
3447+ (fig-forth-auto680):03435 * shift to interpreting,
3448+ (fig-forth-auto680):03436 * make the ASSEMBLER vocabulary current,
3449+ (fig-forth-auto680):03437 * and !CSP to mark the stack
3450+ (fig-forth-auto680):03438 * in preparation for assembling low-level code.
3451+ (fig-forth-auto680):03439 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
3452+ (fig-forth-auto680):03440 * and compiles (;CODE),
3453+ (fig-forth-auto680):03441 * which will do the actual work of changing
3454+ (fig-forth-auto680):03442 * the LATEST definition's characteristic when the defining word runs.
3455+ (fig-forth-auto680):03443 * Assembly is done by the interpreter, rather than the compiler.
3456+ (fig-forth-auto680):03444 * I could have avoided the anomalous three-byte code fields by
3457+ (fig-forth-auto680):03445 *
3458+ (fig-forth-auto680):03446 * Note that the ASSEMBLER is not part of the model (at this time).
3459+ (fig-forth-auto680):03447 * That means that, until the assembler is ready,
3460+ (fig-forth-auto680):03448 * if you want to define low-level words,
3461+ (fig-forth-auto680):03449 * you have to poke (comma) in hand-assembled stuff.
3462+ (fig-forth-auto680):03450 *
3463+1C48 C5 (fig-forth-auto680):03451 FCB $C5 immediate
3464+1C49 3B434F44 (fig-forth-auto680):03452 FCC ';COD' ; ';CODE'
3465+1C4D C5 (fig-forth-auto680):03453 FCB $C5
3466+1C4E 1C30 (fig-forth-auto680):03454 FDB PSCODE-10
3467+1C50 17B91B921BC71C3A (fig-forth-auto680):03455 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
3468+ 1BFF1BDD1D5B
3469+1C5E 1667 (fig-forth-auto680):03456 FDB SEMIS
3470+ (fig-forth-auto680):03457 * note: "QSTACK" will be replaced by "ASSEMBLER" later
3471+ (fig-forth-auto680):03458 *
3472+ (fig-forth-auto680):03459 * ######>> screen 43 <<
3473+ (fig-forth-auto680):03460 * ======>> 119 <<
3474+ (fig-forth-auto680):03461 * ( --- ) C
3475+ (fig-forth-auto680):03462 * Make the word currently being defined
3476+ (fig-forth-auto680):03463 * build a header for DOES> definitions.
3477+ (fig-forth-auto680):03464 * Actually just compiles a CONSTANT zero
3478+ (fig-forth-auto680):03465 * which can be overwritten later by DOES>.
3479+ (fig-forth-auto680):03466 * Since the fig models were established, this technique has been deprecated.
3480+ (fig-forth-auto680):03467 *
3481+ (fig-forth-auto680):03468 * Note that <BUILDS is not IMMEDIATE,
3482+ (fig-forth-auto680):03469 * and therefore executes during a definition's run-time,
3483+ (fig-forth-auto680):03470 * rather than its compile-time.
3484+ (fig-forth-auto680):03471 * It is not intended to be used directly,
3485+ (fig-forth-auto680):03472 * but rather so that one definition word can build another.
3486+ (fig-forth-auto680):03473 * Also, note that nothing particularly special happens
3487+ (fig-forth-auto680):03474 * in the defining definition until DOES> executes.
3488+ (fig-forth-auto680):03475 * The name <BUILDS is intended to be a reminder of what is about to occur.
3489+ (fig-forth-auto680):03476 *
3490+ (fig-forth-auto680):03477 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
3491+1C60 87 (fig-forth-auto680):03478 FCB $87
3492+1C61 3C4255494C44 (fig-forth-auto680):03479 FCC '<BUILD' ; '<BUILDS'
3493+1C67 D3 (fig-forth-auto680):03480 FCB $D3
3494+1C68 1C48 (fig-forth-auto680):03481 FDB SEMIC-8
3495+1C6A 17B9183D17DF (fig-forth-auto680):03482 BUILDS FDB DOCOL,ZERO,CON
3496+1C70 1667 (fig-forth-auto680):03483 FDB SEMIS
3497+ (fig-forth-auto680):03484 *
3498+ (fig-forth-auto680):03485 * ======>> 120 <<
3499+ (fig-forth-auto680):03486 * ( --- ) ( IP *** ) C
3500+ (fig-forth-auto680):03487 * Define run-time behavior of definitions compiled/defined
3501+ (fig-forth-auto680):03488 * by a high-level defining definition --
3502+ (fig-forth-auto680):03489 * the FORTH equivalent of a compiler-compiler.
3503+ (fig-forth-auto680):03490 * DOES> assumes that the LATEST symbol table entry
3504+ (fig-forth-auto680):03491 * has at least one word of parameter field,
3505+ (fig-forth-auto680):03492 * which <BUILDS provides.
3506+ (fig-forth-auto680):03493 * Note that DOES> is also not IMMEDIATE.
3507+ (fig-forth-auto680):03494 *
3508+ (fig-forth-auto680):03495 * When the defining word containing DOES> executes the DOES> icode,
3509+ (fig-forth-auto680):03496 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
3510+ (fig-forth-auto680):03497 * overwrites the first word of that symbol's parameter field with its own IP,
3511+ (fig-forth-auto680):03498 * and pops the previous IP from the return stack.
3512+ (fig-forth-auto680):03499 * The icodes which follow DOES> in the stream
3513+ (fig-forth-auto680):03500 * do not execute at the defining word's run-time.
3514+ (fig-forth-auto680):03501 *
3515+ (fig-forth-auto680):03502 * Examining XDOES in the virtual machine shows
3516+ (fig-forth-auto680):03503 * that the defined word will execute those icodes
3517+ (fig-forth-auto680):03504 * which follow DOES> at its own run-time.
3518+ (fig-forth-auto680):03505 *
3519+ (fig-forth-auto680):03506 * The advantage of this kind of behaviour,
3520+ (fig-forth-auto680):03507 * which you will also note in ;CODE,
3521+ (fig-forth-auto680):03508 * is that the defined word can contain
3522+ (fig-forth-auto680):03509 * both operations and data to be operated on.
3523+ (fig-forth-auto680):03510 * This is how FORTH data objects define their own behavior.
3524+ (fig-forth-auto680):03511 *
3525+ (fig-forth-auto680):03512 * Finally, note that the effective parameter field for DOES> definitions
3526+ (fig-forth-auto680):03513 * starts two NATWID words after the CFA, instead of just one
3527+ (fig-forth-auto680):03514 * (four bytes instead of two in a sixteen-bit addressing Forth).
3528+ (fig-forth-auto680):03515 *
3529+ (fig-forth-auto680):03516 * VOCABULARYs will use this. See definition of word FORTH.
3530+1C72 85 (fig-forth-auto680):03517 FCB $85
3531+1C73 444F4553 (fig-forth-auto680):03518 FCC 'DOES' ; 'DOES>'
3532+1C77 BE (fig-forth-auto680):03519 FCB $BE
3533+1C78 1C60 (fig-forth-auto680):03520 FDB BUILDS-10
3534+ (fig-forth-auto680):03521 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
3535+1C7A 17B91690 (fig-forth-auto680):03522 DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
3536+1C7E 1AD01B12178A (fig-forth-auto680):03523 FDB LATEST,PFA,STORE
3537+1C84 1C3A (fig-forth-auto680):03524 FDB PSCODE
3538+ (fig-forth-auto680):03525 *
3539+ (fig-forth-auto680):03526 * ( --- PFA+NATWID ) ( *** IP )
3540+ (fig-forth-auto680):03527 * Characteristic of a DOES> defined word.
3541+ (fig-forth-auto680):03528 * The characteristics of DOES> definitions are written in high-level
3542+ (fig-forth-auto680):03529 * Forth codes rather than native CPU machine level code.
3543+ (fig-forth-auto680):03530 * The first parameter word points to the high-level characteristic.
3544+ (fig-forth-auto680):03531 * This routine's job is to push the IP,
3545+ (fig-forth-auto680):03532 * load the high level characteristic pointer in IP,
3546+ (fig-forth-auto680):03533 * and leave the address following the characteristic pointer on the stack
3547+ (fig-forth-auto680):03534 * so the parameter field can be accessed.
3548+1C86 ECE4 (fig-forth-auto680):03535 DODOES LDD ,S ; Keep the return address.
3549+1C88 10AFE4 (fig-forth-auto680):03536 STY ,S ; Save/nest the current IP on the return stack.
3550+1C8B 10AE02 (fig-forth-auto680):03537 LDY NATWID,X ; First parameter is new IP.
3551+1C8E 3004 (fig-forth-auto680):03538 LEAX 2*NATWID,X ; Address of second parameter.
3552+1C90 3610 (fig-forth-auto680):03539 PSHU X
3553+1C92 1F05 (fig-forth-auto680):03540 TFR D,PC ; Synthetic return.
3554+ (fig-forth-auto680):03541 *
3555+ (fig-forth-auto680):03542 * From the 6800 model:
3556+ (fig-forth-auto680):03543 * DODOES LDA IP
3557+ (fig-forth-auto680):03544 * LDB IP+1
3558+ (fig-forth-auto680):03545 * LDX RP make room on return stack
3559+ (fig-forth-auto680):03546 * LEAX -1,X ;
3560+ (fig-forth-auto680):03547 * LEAX -1,X ;
3561+ (fig-forth-auto680):03548 * STX RP
3562+ (fig-forth-auto680):03549 * STA 2,X push return address
3563+ (fig-forth-auto680):03550 * STB 3,X
3564+ (fig-forth-auto680):03551 * LDX W get addr of pointer to run-time code
3565+ (fig-forth-auto680):03552 * LEAX 1,X ;
3566+ (fig-forth-auto680):03553 * LEAX 1,X ;
3567+ (fig-forth-auto680):03554 * STX N stash it in scratch area
3568+ (fig-forth-auto680):03555 * LDX 0,X get new IP
3569+ (fig-forth-auto680):03556 * STX IP
3570+ (fig-forth-auto680):03557 * CLRA ; get address of parameter
3571+ (fig-forth-auto680):03558 * LDB #2
3572+ (fig-forth-auto680):03559 * ADDB N+1
3573+ (fig-forth-auto680):03560 * ADCA N
3574+ (fig-forth-auto680):03561 * PSHS B ; and push it on data stack
3575+ (fig-forth-auto680):03562 * PSHS A ;
3576+ (fig-forth-auto680):03563 * JMP NEXT2
3577+ (fig-forth-auto680):03564 *
3578+ (fig-forth-auto680):03565 * ######>> screen 44 <<
3579+ (fig-forth-auto680):03566 * ======>> 121 <<
3580+ (fig-forth-auto680):03567 * ( strptr --- strptr+1 count )
3581+ (fig-forth-auto680):03568 * Convert counted string to string and count.
3582+ (fig-forth-auto680):03569 * (Fetch the byte at strptr, post-increment.)
3583+1C94 85 (fig-forth-auto680):03570 FCB $85
3584+1C95 434F554E (fig-forth-auto680):03571 FCC 'COUN' ; 'COUNT'
3585+1C99 D4 (fig-forth-auto680):03572 FCB $D4
3586+1C9A 1C72 (fig-forth-auto680):03573 FDB DOES-8
3587+1C9C 17B9174519AB1736 (fig-forth-auto680):03574 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
3588+ 177E
3589+1CA6 1667 (fig-forth-auto680):03575 FDB SEMIS
3590+ (fig-forth-auto680):03576 *
3591+ (fig-forth-auto680):03577 * ======>> 122 <<
3592+ (fig-forth-auto680):03578 * ( strptr count --- )
3593+ (fig-forth-auto680):03579 * EMIT count characters at strptr.
3594+1CA8 84 (fig-forth-auto680):03580 FCB $84
3595+1CA9 545950 (fig-forth-auto680):03581 FCC 'TYP' ; 'TYPE'
3596+1CAC C5 (fig-forth-auto680):03582 FCB $C5
3597+1CAD 1C94 (fig-forth-auto680):03583 FDB COUNT-8
3598+1CAF 17B91A8A1409 (fig-forth-auto680):03584 TYPE FDB DOCOL,DDUP,ZBRAN
3599+1CB5 0016 (fig-forth-auto680):03585 FDB TYPE3-*-NATWID
3600+1CB7 171C16C617361453 (fig-forth-auto680):03586 FDB OVER,PLUS,SWAP,XDO
3601+1CBF 1465177E1542141D (fig-forth-auto680):03587 TYPE2 FDB I,CAT,EMIT,XLOOP
3602+1CC7 FFF6 (fig-forth-auto680):03588 FDB TYPE2-*-NATWID
3603+1CC9 13FA (fig-forth-auto680):03589 FDB BRAN
3604+1CCB 0002 (fig-forth-auto680):03590 FDB TYPE4-*-NATWID
3605+1CCD 172A (fig-forth-auto680):03591 TYPE3 FDB DROP
3606+1CCF 1667 (fig-forth-auto680):03592 TYPE4 FDB SEMIS
3607+ (fig-forth-auto680):03593 *
3608+ (fig-forth-auto680):03594 * ======>> 123 <<
3609+ (fig-forth-auto680):03595 * ( strptr count1 --- strptr count2 )
3610+ (fig-forth-auto680):03596 * Supress trailing blanks (subtract count of trailing blanks from strptr).
3611+1CD1 89 (fig-forth-auto680):03597 FCB $89
3612+1CD2 2D545241494C494E (fig-forth-auto680):03598 FCC '-TRAILIN' ; '-TRAILING'
3613+1CDA C7 (fig-forth-auto680):03599 FCB $C7
3614+1CDB 1CA8 (fig-forth-auto680):03600 FDB TYPE-7
3615+1CDD 17B91745183D1453 (fig-forth-auto680):03601 DTRAIL FDB DOCOL,DUP,ZERO,XDO
3616+1CE5 171C171C16C61845 (fig-forth-auto680):03602 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
3617+ 1A04177E185E
3618+1CF3 1A041409 (fig-forth-auto680):03603 FDB SUB,ZBRAN
3619+1CF7 0006 (fig-forth-auto680):03604 FDB DTRAL3-*-NATWID
3620+1CF9 167513FA (fig-forth-auto680):03605 FDB LEAVE,BRAN
3621+1CFD 0004 (fig-forth-auto680):03606 FDB DTRAL4-*-NATWID
3622+1CFF 18451A04 (fig-forth-auto680):03607 DTRAL3 FDB ONE,SUB
3623+1D03 141D (fig-forth-auto680):03608 DTRAL4 FDB XLOOP
3624+1D05 FFDE (fig-forth-auto680):03609 FDB DTRAL2-*-NATWID
3625+1D07 1667 (fig-forth-auto680):03610 FDB SEMIS
3626+ (fig-forth-auto680):03611 *
3627+ (fig-forth-auto680):03612 * ======>> 124 <<
3628+ (fig-forth-auto680):03613 * ( --- )
3629+ (fig-forth-auto680):03614 * TYPE counted string out of instruction stream (updating IP).
3630+1D09 84 (fig-forth-auto680):03615 FCB $84
3631+1D0A 282E22 (fig-forth-auto680):03616 FCC '(."' ; '(.")'
3632+1D0D A9 (fig-forth-auto680):03617 FCB $A9
3633+1D0E 1CD1 (fig-forth-auto680):03618 FDB DTRAIL-12
3634+ (fig-forth-auto680):03619 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
3635+ (fig-forth-auto680):03620 * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
3636+1D10 17B9169C1C9C1745 (fig-forth-auto680):03621 PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
3637+ 19AB
3638+1D1A 169016C616811CAF (fig-forth-auto680):03622 FDB FROMR,PLUS,TOR,TYPE
3639+1D22 1667 (fig-forth-auto680):03623 FDB SEMIS
3640+ (fig-forth-auto680):03624 *
3641+ (fig-forth-auto680):03625 * ======>> 125 <<
3642+ (fig-forth-auto680):03626 * ( --- ) P
3643+ (fig-forth-auto680):03627 * { ." something-to-be-printed " } typical input
3644+ (fig-forth-auto680):03628 * Use WORD to parse to trailing quote;
3645+ (fig-forth-auto680):03629 * if compiling, compile XDOTQ and string parsed,
3646+ (fig-forth-auto680):03630 * otherwise, TYPE string.
3647+1D24 C2 (fig-forth-auto680):03631 FCB $C2 immediate
3648+1D25 2E (fig-forth-auto680):03632 FCC '.' ; '."'
3649+1D26 A2 (fig-forth-auto680):03633 FCB $A2
3650+1D27 1D09 (fig-forth-auto680):03634 FDB PDOTQ-7
3651+1D29 17B9 (fig-forth-auto680):03635 DOTQ FDB DOCOL
3652+1D2B 13A7 (fig-forth-auto680):03636 FDB LIT8
3653+1D2D 22 (fig-forth-auto680):03637 FCB $22 ascii quote
3654+1D2E 195817721409 (fig-forth-auto680):03638 FDB STATE,AT,ZBRAN
3655+1D34 0012 (fig-forth-auto680):03639 FDB DOTQ1-*-NATWID
3656+1D36 1BC71D101EBC (fig-forth-auto680):03640 FDB COMPIL,PDOTQ,WORD
3657+1D3C 19C7177E19AB19D7 (fig-forth-auto680):03641 FDB HERE,CAT,ONEP,ALLOT,BRAN
3658+ 13FA
3659+1D46 0008 (fig-forth-auto680):03642 FDB DOTQ2-*-NATWID
3660+1D48 1EBC19C71C9C1CAF (fig-forth-auto680):03643 DOTQ1 FDB WORD,HERE,COUNT,TYPE
3661+1D50 1667 (fig-forth-auto680):03644 DOTQ2 FDB SEMIS
3662+ (fig-forth-auto680):03645 *
3663+ (fig-forth-auto680):03646 * ######>> screen 45 <<
3664+ (fig-forth-auto680):03647 * ======>> 126 <<== MACHINE DEPENDENT
3665+ (fig-forth-auto680):03648 * ( --- ) ( *** )
3666+ (fig-forth-auto680):03649 * ( --- IN BLK ) ( anything *** nothing )
3667+ (fig-forth-auto680):03650 * ERROR if parameter stack out of bounds.
3668+ (fig-forth-auto680):03651 *
3669+ (fig-forth-auto680):03652 * But checking whether the stack is in bounds or not
3670+ (fig-forth-auto680):03653 * really should not use the stack.
3671+ (fig-forth-auto680):03654 * And there really should be a ?RSTACK, as well.
3672+1D52 86 (fig-forth-auto680):03655 FCB $86
3673+1D53 3F53544143 (fig-forth-auto680):03656 FCC '?STAC' ; '?STACK'
3674+1D58 CB (fig-forth-auto680):03657 FCB $CB
3675+1D59 1D24 (fig-forth-auto680):03658 FDB DOTQ-5
3676+1D5B 17B913A7 (fig-forth-auto680):03659 QSTACK FDB DOCOL,LIT8
3677+ (fig-forth-auto680):03660 * FCB $12
3678+1D5F 12 (fig-forth-auto680):03661 FCB SINIT-ORIG
3679+ (fig-forth-auto680):03662 * But why use that instead of XSPZER (S0)?
3680+ (fig-forth-auto680):03663 * Multi-user or multi-tasking would not want that.
3681+ (fig-forth-auto680):03664 * CMPU <XSPZER
3682+ (fig-forth-auto680):03665 * FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
3683+1D60 189C177216401A1D (fig-forth-auto680):03666 FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
3684+ 1845
3685+1D6A 1B39 (fig-forth-auto680):03667 FDB QERR
3686+ (fig-forth-auto680):03668 * prints 'empty stack'
3687+ (fig-forth-auto680):03669 *
3688+1D6C 1640 (fig-forth-auto680):03670 QSTAC2 FDB SPAT
3689+ (fig-forth-auto680):03671 * Here, we compare with a value at least 128
3690+ (fig-forth-auto680):03672 * higher than dict. ptr. (DICTPT)
3691+1D6E 19C713A7 (fig-forth-auto680):03673 FDB HERE,LIT8
3692+1D72 80 (fig-forth-auto680):03674 FCB $80 ; This is a rough check anyway, leave it as is.
3693+1D73 16C61A1D1409 (fig-forth-auto680):03675 FDB PLUS,LESS,ZBRAN
3694+1D79 0004 (fig-forth-auto680):03676 FDB QSTAC3-*-NATWID
3695+1D7B 184D (fig-forth-auto680):03677 FDB TWO ; NOT the NATWID constant!
3696+1D7D 1B39 (fig-forth-auto680):03678 FDB QERR
3697+ (fig-forth-auto680):03679 * prints 'full stack'
3698+ (fig-forth-auto680):03680 *
3699+1D7F 1667 (fig-forth-auto680):03681 QSTAC3 FDB SEMIS
3700+ (fig-forth-auto680):03682 *
3701+ (fig-forth-auto680):03683 * ======>> 127 << this word's function
3702+ (fig-forth-auto680):03684 * is done by ?STACK in this version
3703+ (fig-forth-auto680):03685 * FCB $85
3704+ (fig-forth-auto680):03686 * FCC 4,?FREE
3705+ (fig-forth-auto680):03687 * FCB $C5
3706+ (fig-forth-auto680):03688 * FDB QSTACK-9
3707+ (fig-forth-auto680):03689 *QFREE FDB DOCOL,SPAT,HERE,LIT8
3708+ (fig-forth-auto680):03690 * FCB $80
3709+ (fig-forth-auto680):03691 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
3710+ (fig-forth-auto680):03692 *
3711+ (fig-forth-auto680):03693 * ######>> screen 46 <<
3712+ (fig-forth-auto680):03694 * ======>> 128 <<
3713+ (fig-forth-auto680):03695 * ( buffer n --- )
3714+ (fig-forth-auto680):03696 * ***** Check that this is how it works here:
3715+ (fig-forth-auto680):03697 * Get up to n-1 characters from the keyboard,
3716+ (fig-forth-auto680):03698 * storing at buffer and echoing, with backspace editing,
3717+ (fig-forth-auto680):03699 * quitting when a CR is read.
3718+ (fig-forth-auto680):03700 * Terminate it with a NUL.
3719+1D81 86 (fig-forth-auto680):03701 FCB $86
3720+1D82 4558504543 (fig-forth-auto680):03702 FCC 'EXPEC' ; 'EXPECT'
3721+1D87 D4 (fig-forth-auto680):03703 FCB $D4
3722+1D88 1D52 (fig-forth-auto680):03704 FDB QSTACK-9
3723+1D8A 17B9171C16C6171C (fig-forth-auto680):03705 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
3724+ 1453
3725+ (fig-forth-auto680):03706 * EXPEC2 FDB KEY,DUP,LIT8
3726+1D94 1556 (fig-forth-auto680):03707 EXPEC2 FDB KEY
3727+1D96 1399001C13B9 (fig-forth-auto680):03708 FDB LIT,$1C,SHOTOS ; DBG
3728+1D9C 174513A7 (fig-forth-auto680):03709 FDB DUP,LIT8
3729+1DA0 0E (fig-forth-auto680):03710 FCB BACKSP-ORIG
3730+1DA1 189C17721A111409 (fig-forth-auto680):03711 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
3731+1DA9 001D (fig-forth-auto680):03712 FDB EXPEC3-*-NATWID
3732+1DAB 172A13A7 (fig-forth-auto680):03713 FDB DROP,LIT8
3733+1DAF 08 (fig-forth-auto680):03714 FCB 8 ( backspace character to emit )
3734+1DB0 171C14651A111745 (fig-forth-auto680):03715 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
3735+ 1690184D1A0416C6
3736+1DC0 16811A0413FA (fig-forth-auto680):03716 FDB TOR,SUB,BRAN
3737+1DC6 0025 (fig-forth-auto680):03717 FDB EXPEC6-*-NATWID
3738+1DC8 174513A7 (fig-forth-auto680):03718 EXPEC3 FDB DUP,LIT8
3739+1DCC 0D (fig-forth-auto680):03719 FCB $D ( carriage return )
3740+1DCD 1A111409 (fig-forth-auto680):03720 FDB EQUAL,ZBRAN
3741+1DD1 000C (fig-forth-auto680):03721 FDB EXPEC4-*-NATWID
3742+1DD3 1675172A185E183D (fig-forth-auto680):03722 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
3743+ 13FA
3744+1DDD 0002 (fig-forth-auto680):03723 FDB EXPEC5-*-NATWID
3745+1DDF 1745 (fig-forth-auto680):03724 EXPEC4 FDB DUP
3746+1DE1 14651798183D1465 (fig-forth-auto680):03725 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
3747+ 19AB178A
3748+1DED 1542141D (fig-forth-auto680):03726 EXPEC6 FDB EMIT,XLOOP
3749+1DF1 FFA1 (fig-forth-auto680):03727 FDB EXPEC2-*-NATWID
3750+1DF3 172A (fig-forth-auto680):03728 FDB DROP
3751+1DF5 1667 (fig-forth-auto680):03729 FDB SEMIS
3752+ (fig-forth-auto680):03730 *
3753+ (fig-forth-auto680):03731 * ======>> 129 <<
3754+ (fig-forth-auto680):03732 * ( --- )
3755+ (fig-forth-auto680):03733 * EXPECT 128 (TWID) characters to TIB.
3756+1DF7 85 (fig-forth-auto680):03734 FCB $85
3757+1DF8 51554552 (fig-forth-auto680):03735 FCC 'QUER' ; 'QUERY'
3758+1DFC D9 (fig-forth-auto680):03736 FCB $D9
3759+1DFD 1D81 (fig-forth-auto680):03737 FDB EXPECT-9
3760+1DFF 17B918BE177219A2 (fig-forth-auto680):03738 QUERY FDB DOCOL,TIB,AT,COLUMS
3761+1E07 17721D8A183D190F (fig-forth-auto680):03739 FDB AT,EXPECT,ZERO,IN,STORE
3762+ 178A
3763+1E11 1667 (fig-forth-auto680):03740 FDB SEMIS
3764+ (fig-forth-auto680):03741 *
3765+ (fig-forth-auto680):03742 * ======>> 130 <<
3766+ (fig-forth-auto680):03743 * ( --- ) P
3767+ (fig-forth-auto680):03744 * End interpretation of a line or screen, and/or prepare for a new block.
3768+ (fig-forth-auto680):03745 * Note that the name of this definition is an empty string,
3769+ (fig-forth-auto680):03746 * so it matches on the terminating NUL in the terminal or block buffer.
3770+1E13 C1 (fig-forth-auto680):03747 FCB $C1 immediate < carriage return >
3771+1E14 80 (fig-forth-auto680):03748 FCB $80
3772+1E15 1DF7 (fig-forth-auto680):03749 FDB QUERY-8
3773+1E17 17B9190617721409 (fig-forth-auto680):03750 NULL FDB DOCOL,BLK,AT,ZBRAN
3774+1E1F 0024 (fig-forth-auto680):03751 FDB NULL2-*-NATWID
3775+1E21 184519061751 (fig-forth-auto680):03752 FDB ONE,BLK,PSTORE
3776+1E27 183D190F178A1906 (fig-forth-auto680):03753 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
3777+ 1772188E2335
3778+1E35 16A3 (fig-forth-auto680):03754 FDB ZEQU
3779+ (fig-forth-auto680):03755 * check for end of screen
3780+1E37 1409 (fig-forth-auto680):03756 FDB ZBRAN
3781+1E39 0006 (fig-forth-auto680):03757 FDB NULL1-*-NATWID
3782+1E3B 1B6A1690172A (fig-forth-auto680):03758 FDB QEXEC,FROMR,DROP
3783+1E41 13FA (fig-forth-auto680):03759 NULL1 FDB BRAN
3784+1E43 0004 (fig-forth-auto680):03760 FDB NULL3-*-NATWID
3785+1E45 1690172A (fig-forth-auto680):03761 NULL2 FDB FROMR,DROP
3786+1E49 1667 (fig-forth-auto680):03762 NULL3 FDB SEMIS
3787+ (fig-forth-auto680):03763 *
3788+ (fig-forth-auto680):03764 * ######>> screen 47 <<
3789+ (fig-forth-auto680):03765 * ======>> 133 <<
3790+ (fig-forth-auto680):03766 * ( adr n b --- )
3791+ (fig-forth-auto680):03767 * Fill n bytes at adr with b.
3792+1E4B 84 (fig-forth-auto680):03768 FCB $84
3793+1E4C 46494C (fig-forth-auto680):03769 FCC 'FIL' ; 'FILL'
3794+1E4F CC (fig-forth-auto680):03770 FCB $CC
3795+1E50 1E13 (fig-forth-auto680):03771 FDB NULL-4
3796+1E52 17B917361681171C (fig-forth-auto680):03772 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
3797+ 1798174519AB
3798+1E60 169018451A041584 (fig-forth-auto680):03773 FDB FROMR,ONE,SUB,CMOVE
3799+1E68 1667 (fig-forth-auto680):03774 FDB SEMIS
3800+ (fig-forth-auto680):03775 *
3801+ (fig-forth-auto680):03776 * ======>> 134 <<
3802+ (fig-forth-auto680):03777 * ( adr n --- )
3803+ (fig-forth-auto680):03778 * Fill n bytes with 0.
3804+1E6A 85 (fig-forth-auto680):03779 FCB $85
3805+1E6B 45524153 (fig-forth-auto680):03780 FCC 'ERAS' ; 'ERASE'
3806+1E6F C5 (fig-forth-auto680):03781 FCB $C5
3807+1E70 1E4B (fig-forth-auto680):03782 FDB FILL-7
3808+1E72 17B9183D1E52 (fig-forth-auto680):03783 ERASE FDB DOCOL,ZERO,FILL
3809+1E78 1667 (fig-forth-auto680):03784 FDB SEMIS
3810+ (fig-forth-auto680):03785 *
3811+ (fig-forth-auto680):03786 * ======>> 135 <<
3812+ (fig-forth-auto680):03787 * ( adr n --- )
3813+ (fig-forth-auto680):03788 * Fill n bytes with ASCII SPACE.
3814+1E7A 86 (fig-forth-auto680):03789 FCB $86
3815+1E7B 424C414E4B (fig-forth-auto680):03790 FCC 'BLANK' ; 'BLANKS'
3816+1E80 D3 (fig-forth-auto680):03791 FCB $D3
3817+1E81 1E6A (fig-forth-auto680):03792 FDB ERASE-8
3818+1E83 17B9185E1E52 (fig-forth-auto680):03793 BLANKS FDB DOCOL,BL,FILL
3819+1E89 1667 (fig-forth-auto680):03794 FDB SEMIS
3820+ (fig-forth-auto680):03795 *
3821+ (fig-forth-auto680):03796 * ======>> 136 <<
3822+ (fig-forth-auto680):03797 * ( c --- )
3823+ (fig-forth-auto680):03798 * Format a character at the left of the HLD output buffer.
3824+1E8B 84 (fig-forth-auto680):03799 FCB $84
3825+1E8C 484F4C (fig-forth-auto680):03800 FCC 'HOL' ; 'HOLD'
3826+1E8F C4 (fig-forth-auto680):03801 FCB $C4
3827+1E90 1E7A (fig-forth-auto680):03802 FDB BLANKS-9
3828+1E92 17B91399FFFF1994 (fig-forth-auto680):03803 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
3829+ 1751199417721798
3830+1EA2 1667 (fig-forth-auto680):03804 FDB SEMIS
3831+ (fig-forth-auto680):03805 *
3832+ (fig-forth-auto680):03806 * ======>> 137 <<
3833+ (fig-forth-auto680):03807 * ( --- adr )
3834+ (fig-forth-auto680):03808 * Give the address of the output PAD buffer.
3835+ (fig-forth-auto680):03809 * PAD points to the end of a 68 byte buffer for numeric conversion.
3836+1EA4 83 (fig-forth-auto680):03810 FCB $83
3837+1EA5 5041 (fig-forth-auto680):03811 FCC 'PA' ; 'PAD'
3838+1EA7 C4 (fig-forth-auto680):03812 FCB $C4
3839+1EA8 1E8B (fig-forth-auto680):03813 FDB HOLD-7
3840+1EAA 17B919C713A7 (fig-forth-auto680):03814 PAD FDB DOCOL,HERE,LIT8
3841+1EB0 44 (fig-forth-auto680):03815 FCB $44
3842+1EB1 16C6 (fig-forth-auto680):03816 FDB PLUS
3843+1EB3 1667 (fig-forth-auto680):03817 FDB SEMIS
3844+ (fig-forth-auto680):03818 *
3845+ (fig-forth-auto680):03819 * ######>> screen 48 <<
3846+ (fig-forth-auto680):03820 * ======>> 138 <<
3847+ (fig-forth-auto680):03821 * ( c --- )
3848+ (fig-forth-auto680):03822 * Scan a string terminated by the character c or ASCII NUL out of input;
3849+ (fig-forth-auto680):03823 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
3850+ (fig-forth-auto680):03824 * Leading c are passed over, per ENCLOSE.
3851+ (fig-forth-auto680):03825 * Scans from BLK, or from TIB if BLK is zero.
3852+ (fig-forth-auto680):03826 * May overwrite the numeric conversion pad,
3853+ (fig-forth-auto680):03827 * if really long (length > 31) symbols are scanned.
3854+1EB5 84 (fig-forth-auto680):03828 FCB $84
3855+1EB6 574F52 (fig-forth-auto680):03829 FCC 'WOR' ; 'WORD'
3856+1EB9 C4 (fig-forth-auto680):03830 FCB $C4
3857+1EBA 1EA4 (fig-forth-auto680):03831 FDB PAD-6
3858+1EBC 17B9190617721409 (fig-forth-auto680):03832 WORD FDB DOCOL,BLK,AT,ZBRAN
3859+1EC4 000A (fig-forth-auto680):03833 FDB WORD2-*-NATWID
3860+1EC6 19061772249213FA (fig-forth-auto680):03834 FDB BLK,AT,BLOCK,BRAN
3861+1ECE 0004 (fig-forth-auto680):03835 FDB WORD3-*-NATWID
3862+1ED0 18BE1772 (fig-forth-auto680):03836 WORD2 FDB TIB,AT
3863+1ED4 190F177216C61736 (fig-forth-auto680):03837 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
3864+ 14FD19C713A7
3865+1EE2 22 (fig-forth-auto680):03838 FCB 34
3866+1EE3 1E83190F1751171C (fig-forth-auto680):03839 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
3867+ 1A041681169C19C7
3868+1EF3 179816C619C719AB (fig-forth-auto680):03840 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
3869+ 16901584
3870+1EFF 1667 (fig-forth-auto680):03841 FDB SEMIS
3871+ (fig-forth-auto680):03842 *
3872+ (fig-forth-auto680):03843 * ######>> screen 49 <<
3873+ (fig-forth-auto680):03844 * ======>> 139 <<
3874+ (fig-forth-auto680):03845 * ( d1 string --- d2 adr )
3875+ (fig-forth-auto680):03846 * Convert the text at string into a number, accumulating the result into d1,
3876+ (fig-forth-auto680):03847 * leaving adr pointing to the first character not converted.
3877+ (fig-forth-auto680):03848 * If DPL is non-negative at entry,
3878+ (fig-forth-auto680):03849 * accumulates the number of characters converted into DPL.
3879+1F01 88 (fig-forth-auto680):03850 FCB $88
3880+1F02 284E554D424552 (fig-forth-auto680):03851 FCC '(NUMBER' ; '(NUMBER)'
3881+1F09 A9 (fig-forth-auto680):03852 FCB $A9
3882+1F0A 1EB5 (fig-forth-auto680):03853 FDB WORD-7
3883+1F0C 17B9 (fig-forth-auto680):03854 PNUMB FDB DOCOL
3884+1F0E 19AB17451681177E (fig-forth-auto680):03855 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3885+ 1963177214741409
3886+1F1E 002A (fig-forth-auto680):03856 FDB PNUMB4-*-NATWID
3887+1F20 17361963177215A5 (fig-forth-auto680):03857 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
3888+ 172A1A431963
3889+1F2E 177215A516D4196D (fig-forth-auto680):03858 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3890+ 177219AB1409
3891+1F3C 0006 (fig-forth-auto680):03859 FDB PNUMB3-*-NATWID
3892+1F3E 1845196D1751 (fig-forth-auto680):03860 FDB ONE,DPL,PSTORE
3893+1F44 169013FA (fig-forth-auto680):03861 PNUMB3 FDB FROMR,BRAN
3894+1F48 FFC4 (fig-forth-auto680):03862 FDB PNUMB2-*-NATWID
3895+1F4A 1690 (fig-forth-auto680):03863 PNUMB4 FDB FROMR
3896+1F4C 1667 (fig-forth-auto680):03864 FDB SEMIS
3897+ (fig-forth-auto680):03865 *
3898+ (fig-forth-auto680):03866 * ======>> 140 <<
3899+ (fig-forth-auto680):03867 * ( ctstr --- d )
3900+ (fig-forth-auto680):03868 * Convert text at ctstr to a double integer,
3901+ (fig-forth-auto680):03869 * taking the 0 ERROR if the conversion is not valid.
3902+ (fig-forth-auto680):03870 * If a decimal point is present,
3903+ (fig-forth-auto680):03871 * accumulate the count of digits to the decimal point's right into DPL
3904+ (fig-forth-auto680):03872 * (negative DPL at exit indicates single precision).
3905+ (fig-forth-auto680):03873 * ctstr is a counted string
3906+ (fig-forth-auto680):03874 * -- the first byte at ctstr is the length of the string,
3907+ (fig-forth-auto680):03875 * but NUMBER ignores the count and expects a NUL terminator instead.
3908+1F4E 86 (fig-forth-auto680):03876 FCB $86
3909+1F4F 4E554D4245 (fig-forth-auto680):03877 FCC 'NUMBE' ; 'NUMBER'
3910+1F54 D2 (fig-forth-auto680):03878 FCB $D2
3911+1F55 1F01 (fig-forth-auto680):03879 FDB PNUMB-11
3912+1F57 17B9183D183D1A43 (fig-forth-auto680):03880 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
3913+ 174519AB177E13A7
3914+1F67 2D (fig-forth-auto680):03881 FCC "-" minus sign
3915+1F68 1A111745168116C6 (fig-forth-auto680):03882 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
3916+ 1399FFFF
3917+1F74 196D178A1F0C1745 (fig-forth-auto680):03883 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
3918+ 177E185E1A04
3919+1F82 1409 (fig-forth-auto680):03884 FDB ZBRAN
3920+1F84 0013 (fig-forth-auto680):03885 FDB NUMB2-*-NATWID
3921+1F86 1745177E13A7 (fig-forth-auto680):03886 FDB DUP,CAT,LIT8
3922+1F8C 2E (fig-forth-auto680):03887 FCC "."
3923+1F8D 1A04183D1B39183D (fig-forth-auto680):03888 FDB SUB,ZERO,QERR,ZERO,BRAN
3924+ 13FA
3925+1F97 FFDB (fig-forth-auto680):03889 FDB NUMB1-*-NATWID
3926+1F99 172A16901409 (fig-forth-auto680):03890 NUMB2 FDB DROP,FROMR,ZBRAN
3927+1F9F 0002 (fig-forth-auto680):03891 FDB NUMB3-*-NATWID
3928+1FA1 1702 (fig-forth-auto680):03892 FDB DMINUS
3929+1FA3 1667 (fig-forth-auto680):03893 NUMB3 FDB SEMIS
3930+ (fig-forth-auto680):03894 *
3931+ (fig-forth-auto680):03895 * ======>> 141 <<
3932+ (fig-forth-auto680):03896 * ( --- locptr length true ) { -FIND name } typical input
3933+ (fig-forth-auto680):03897 * ( --- false )
3934+ (fig-forth-auto680):03898 * Parse a word, then FIND,
3935+ (fig-forth-auto680):03899 * first in the definition vocabulary,
3936+ (fig-forth-auto680):03900 * then in the CONTEXT (interpretation) vocabulary, if necessary.
3937+ (fig-forth-auto680):03901 * Returns what (FIND) returns, flag and optional location and length.
3938+1FA5 85 (fig-forth-auto680):03902 FCB $85
3939+1FA6 2D46494E (fig-forth-auto680):03903 FCC '-FIN' ; '-FIND'
3940+1FAA C4 (fig-forth-auto680):03904 FCB $C4
3941+1FAB 1F4E (fig-forth-auto680):03905 FDB NUMB-9
3942+1FAD 17B9185E1EBC19C7 (fig-forth-auto680):03906 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
3943+ 193E17721772
3944+1FBB 14AF174516A31409 (fig-forth-auto680):03907 FDB PFIND,DUP,ZEQU,ZBRAN
3945+1FC3 0008 (fig-forth-auto680):03908 FDB DFIND2-*-NATWID
3946+1FC5 172A19C71AD014AF (fig-forth-auto680):03909 FDB DROP,HERE,LATEST,PFIND
3947+1FCD 1667 (fig-forth-auto680):03910 DFIND2 FDB SEMIS
3948+ (fig-forth-auto680):03911 *
3949+ (fig-forth-auto680):03912 * ######>> screen 50 <<
3950+ (fig-forth-auto680):03913 * ======>> 142 <<
3951+ (fig-forth-auto680):03914 * ( anything --- nothing ) ( anything *** nothing )
3952+ (fig-forth-auto680):03915 * An indirection for ABORT, for ERROR,
3953+ (fig-forth-auto680):03916 * which may be modified carefully.
3954+1FCF 87 (fig-forth-auto680):03917 FCB $87
3955+1FD0 2841424F5254 (fig-forth-auto680):03918 FCC '(ABORT' ; '(ABORT)'
3956+1FD6 A9 (fig-forth-auto680):03919 FCB $A9
3957+1FD7 1FA5 (fig-forth-auto680):03920 FDB DFIND-8
3958+1FD9 17B92205 (fig-forth-auto680):03921 PABORT FDB DOCOL,ABORT
3959+1FDD 1667 (fig-forth-auto680):03922 FDB SEMIS
3960+ (fig-forth-auto680):03923 *
3961+ (fig-forth-auto680):03924 * ======>> 143 <<
3962+1FDF 85 (fig-forth-auto680):03925 FCB $85
3963+1FE0 4552524F (fig-forth-auto680):03926 FCC 'ERRO' ; 'ERROR'
3964+1FE4 D2 (fig-forth-auto680):03927 FCB $D2
3965+1FE5 1FCF (fig-forth-auto680):03928 FDB PABORT-10
3966+ (fig-forth-auto680):03929 * This really should not be high level, according to best practices.
3967+ (fig-forth-auto680):03930 * But fixing that cascades through MESSAGE,
3968+ (fig-forth-auto680):03931 * requiring re-architecting the disk block system.
3969+ (fig-forth-auto680):03932 * First, we need to get this transliteration running.
3970+1FE7 17B918D8177216B5 (fig-forth-auto680):03933 ERROR FDB DOCOL,WARN,AT,ZLESS
3971+1FEF 1409 (fig-forth-auto680):03934 FDB ZBRAN
3972+1FF1 0002 (fig-forth-auto680):03935 FDB ERROR2-*-NATWID
3973+ (fig-forth-auto680):03936 * note: WARNING is
3974+ (fig-forth-auto680):03937 * -1 to abort,
3975+ (fig-forth-auto680):03938 * 0 to print error #
3976+ (fig-forth-auto680):03939 * and 1 to print error message from disc
3977+1FF3 1FD9 (fig-forth-auto680):03940 FDB PABORT
3978+1FF5 19C71C9C1CAF1D10 (fig-forth-auto680):03941 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
3979+1FFD 0407 (fig-forth-auto680):03942 FCB 4,7 ( bell )
3980+1FFF 203F20 (fig-forth-auto680):03943 FCC " ? "
3981+2002 252B164D190F1772 (fig-forth-auto680):03944 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
3982+ 1906177221D7
3983+2010 1667 (fig-forth-auto680):03945 FDB SEMIS
3984+ (fig-forth-auto680):03946 *
3985+ (fig-forth-auto680):03947 * ======>> 144 <<
3986+ (fig-forth-auto680):03948 * ( n adr --- )
3987+ (fig-forth-auto680):03949 * Mask byte at adr with n.
3988+ (fig-forth-auto680):03950 * Not in FIG, don't need it for 8 bit characters after all.
3989+ (fig-forth-auto680):03951 * FCB $85
3990+ (fig-forth-auto680):03952 * FCC 'CMAS' ; 'CMASK'
3991+ (fig-forth-auto680):03953 * FCB $CB ; 'K'
3992+ (fig-forth-auto680):03954 * FDB ERROR-8
3993+ (fig-forth-auto680):03955 * CMASK FDB *+NATWID
3994+ (fig-forth-auto680):03956 * LDX ,U++ ; adr
3995+ (fig-forth-auto680):03957 * LDD ,U++ ; mask
3996+ (fig-forth-auto680):03958 * ANDB ,X
3997+ (fig-forth-auto680):03959 * STB ,X
3998+ (fig-forth-auto680):03960 * RTS
3999+ (fig-forth-auto680):03961 *
4000+ (fig-forth-auto680):03962 * ( adr --- adr )
4001+ (fig-forth-auto680):03963 * Mask high bit of tail of name in PAD buffer.
4002+ (fig-forth-auto680):03964 * Not in FIG, need it for 8 bit characters.
4003+2012 86 (fig-forth-auto680):03965 FCB $86
4004+2013 4944464C41 (fig-forth-auto680):03966 FCC 'IDFLA' ; 'IDFLAT'
4005+2018 D4 (fig-forth-auto680):03967 FCB $D4 ; 'T'
4006+2019 1FDF (fig-forth-auto680):03968 FDB ERROR-8
4007+201B 201D (fig-forth-auto680):03969 IDFLAT FDB *+NATWID
4008+201D AEC4 (fig-forth-auto680):03970 LDX ,U
4009+201F E684 (fig-forth-auto680):03971 LDB ,X ; get the count
4010+2021 C43F (fig-forth-auto680):03972 ANDB #CTMASK
4011+2023 A685 (fig-forth-auto680):03973 LDA B,X ; point to the tail
4012+2025 847F (fig-forth-auto680):03974 ANDA #$7F ; Clear the EndOfName flag bit.
4013+2027 A785 (fig-forth-auto680):03975 STA B,X
4014+2029 39 (fig-forth-auto680):03976 RTS
4015+ (fig-forth-auto680):03977 *
4016+ (fig-forth-auto680):03978 * ( symptr --- )
4017+ (fig-forth-auto680):03979 * Print definition's name from its NFA.
4018+202A 83 (fig-forth-auto680):03980 FCB $83
4019+202B 4944 (fig-forth-auto680):03981 FCC 'ID' ; 'ID.'
4020+202D AE (fig-forth-auto680):03982 FCB $AE
4021+202E 2012 (fig-forth-auto680):03983 FDB IDFLAT-9
4022+2030 17B91EAA13A7 (fig-forth-auto680):03984 IDDOT FDB DOCOL,PAD,LIT8
4023+2036 20 (fig-forth-auto680):03985 FCB 32
4024+2037 13A7 (fig-forth-auto680):03986 FDB LIT8
4025+2039 5F (fig-forth-auto680):03987 FCB $5F ( underline )
4026+203A 1E5217451B121AE0 (fig-forth-auto680):03988 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
4027+ 171C1A041EAA
4028+ (fig-forth-auto680):03989 * FDB SWAP,CMOVE,PAD,COUNT,LIT8
4029+2048 173615841EAA (fig-forth-auto680):03990 FDB SWAP,CMOVE,PAD
4030+204E 201B (fig-forth-auto680):03991 FDB IDFLAT
4031+2050 1C9C13A7 (fig-forth-auto680):03992 FDB COUNT,LIT8
4032+2054 1F (fig-forth-auto680):03993 FCB 31
4033+2055 160E1CAF1A57 (fig-forth-auto680):03994 FDB AND,TYPE,SPACE
4034+205B 1667 (fig-forth-auto680):03995 FDB SEMIS
4035+ (fig-forth-auto680):03996 *
4036+ (fig-forth-auto680):03997 * ######>> screen 51 <<
4037+ (fig-forth-auto680):03998 * ======>> 145 <<
4038+ (fig-forth-auto680):03999 * ( --- ) { CREATE name } input
4039+ (fig-forth-auto680):04000 * Parse a name (length < 32 characters) and create a header,
4040+ (fig-forth-auto680):04001 * reporting first duplicate found in either the defining vocabulary
4041+ (fig-forth-auto680):04002 * or the context (interpreting) vocabulary.
4042+ (fig-forth-auto680):04003 * Install the header in the defining vocabulary
4043+ (fig-forth-auto680):04004 * with CFA dangerously pointing to the parameter field.
4044+ (fig-forth-auto680):04005 * Leave the name SMUDGEd.
4045+205D 86 (fig-forth-auto680):04006 FCB $86
4046+205E 4352454154 (fig-forth-auto680):04007 FCC 'CREAT' ; 'CREATE'
4047+2063 C5 (fig-forth-auto680):04008 FCB $C5
4048+2064 202A (fig-forth-auto680):04009 FDB IDDOT-6
4049+2066 17B91FAD1409 (fig-forth-auto680):04010 CREATE FDB DOCOL,DFIND,ZBRAN
4050+206C 0018 (fig-forth-auto680):04011 FDB CREAT2-*-NATWID
4051+206E 172A1D10 (fig-forth-auto680):04012 FDB DROP,PDOTQ
4052+2072 08 (fig-forth-auto680):04013 FCB 8
4053+2073 07 (fig-forth-auto680):04014 FCB 7 ( bel )
4054+2074 72656465663A20 (fig-forth-auto680):04015 FCC "redef: "
4055+207B 1AFD203013A7 (fig-forth-auto680):04016 FDB NFA,IDDOT,LIT8
4056+2081 04 (fig-forth-auto680):04017 FCB 4
4057+2082 252B1A57 (fig-forth-auto680):04018 FDB MESS,SPACE
4058+2086 19C71745177E18CA (fig-forth-auto680):04019 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
4059+ 17721A65
4060+2092 19AB19D7174513A7 (fig-forth-auto680):04020 FDB ONEP,ALLOT,DUP,LIT8
4061+209A A0 (fig-forth-auto680):04021 FCB ($80|FSMUDG) ; Bracket the name.
4062+209B 176519C718451A04 (fig-forth-auto680):04022 FDB TOGGLE,HERE,ONE,SUB,LIT8
4063+ 13A7
4064+20A5 80 (fig-forth-auto680):04023 FCB $80
4065+20A6 17651AD019E3194C (fig-forth-auto680):04024 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
4066+ 1772178A
4067+ (fig-forth-auto680):04025 * FDB HERE,TWOP,COMMA
4068+20B2 19C7180219E3 (fig-forth-auto680):04026 FDB HERE,NATP,COMMA
4069+20B8 1667 (fig-forth-auto680):04027 FDB SEMIS
4070+ (fig-forth-auto680):04028 *
4071+ (fig-forth-auto680):04029 * ######>> screen 52 <<
4072+ (fig-forth-auto680):04030 * ======>> 146 <<
4073+ (fig-forth-auto680):04031 * ( --- ) P
4074+ (fig-forth-auto680):04032 * { [COMPILE] name } typical use
4075+ (fig-forth-auto680):04033 * -DFIND next WORD and COMPILE it, literally;
4076+ (fig-forth-auto680):04034 * used to compile immediate definitions into words.
4077+20BA C9 (fig-forth-auto680):04035 FCB $C9 immediate
4078+20BB 5B434F4D50494C45 (fig-forth-auto680):04036 FCC '[COMPILE' ; '[COMPILE]'
4079+20C3 DD (fig-forth-auto680):04037 FCB $DD
4080+20C4 205D (fig-forth-auto680):04038 FDB CREATE-9
4081+20C6 17B91FAD16A3183D (fig-forth-auto680):04039 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
4082+ 1B39172A1AEF19E3
4083+20D6 1667 (fig-forth-auto680):04040 FDB SEMIS
4084+ (fig-forth-auto680):04041 *
4085+ (fig-forth-auto680):04042 * ======>> 147 <<
4086+ (fig-forth-auto680):04043 * ( n --- ) if compiling. P
4087+ (fig-forth-auto680):04044 * ( n --- n ) if interpreting.
4088+ (fig-forth-auto680):04045 * Compile n as a literal, if compiling.
4089+20D8 C7 (fig-forth-auto680):04046 FCB $C7 immediate
4090+20D9 4C4954455241 (fig-forth-auto680):04047 FCC 'LITERA' ; 'LITERAL'
4091+20DF CC (fig-forth-auto680):04048 FCB $CC
4092+20E0 20BA (fig-forth-auto680):04049 FDB BCOMP-12
4093+20E2 17B9195817721409 (fig-forth-auto680):04050 LITER FDB DOCOL,STATE,AT,ZBRAN
4094+20EA 0006 (fig-forth-auto680):04051 FDB LITER2-*-NATWID
4095+20EC 1BC7139919E3 (fig-forth-auto680):04052 FDB COMPIL,LIT,COMMA
4096+20F2 1667 (fig-forth-auto680):04053 LITER2 FDB SEMIS
4097+ (fig-forth-auto680):04054 *
4098+ (fig-forth-auto680):04055 * ======>> 148 <<
4099+ (fig-forth-auto680):04056 * ( d --- ) if compiling. P
4100+ (fig-forth-auto680):04057 * ( d --- d ) if interpreting.
4101+ (fig-forth-auto680):04058 * Compile d as a double literal, if compiling.
4102+20F4 C8 (fig-forth-auto680):04059 FCB $C8 immediate
4103+20F5 444C4954455241 (fig-forth-auto680):04060 FCC 'DLITERA' ; 'DLITERAL'
4104+20FC CC (fig-forth-auto680):04061 FCB $CC
4105+20FD 20D8 (fig-forth-auto680):04062 FDB LITER-10
4106+20FF 17B9195817721409 (fig-forth-auto680):04063 DLITER FDB DOCOL,STATE,AT,ZBRAN
4107+2107 0006 (fig-forth-auto680):04064 FDB DLITE2-*-NATWID
4108+2109 173620E220E2 (fig-forth-auto680):04065 FDB SWAP,LITER,LITER ; Just two literals in the right order.
4109+210F 1667 (fig-forth-auto680):04066 DLITE2 FDB SEMIS
4110+ (fig-forth-auto680):04067 *
4111+ (fig-forth-auto680):04068 * ######>> screen 53 <<
4112+ (fig-forth-auto680):04069 * ======>> 149 <<
4113+ (fig-forth-auto680):04070 * ( --- )
4114+ (fig-forth-auto680):04071 * Interpret or compile, according to STATE.
4115+ (fig-forth-auto680):04072 * Searches words parsed in dictionary first, via -FIND,
4116+ (fig-forth-auto680):04073 * then checks for valid NUMBER.
4117+ (fig-forth-auto680):04074 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
4118+ (fig-forth-auto680):04075 * ERROR checks the stack via ?STACK before returning to its caller.
4119+2111 89 (fig-forth-auto680):04076 FCB $89
4120+2112 494E544552505245 (fig-forth-auto680):04077 FCC 'INTERPRE' ; 'INTERPRET'
4121+211A D4 (fig-forth-auto680):04078 FCB $D4
4122+211B 20F4 (fig-forth-auto680):04079 FDB DLITER-11
4123+211D 17B9 (fig-forth-auto680):04080 INTERP FDB DOCOL
4124+211F 1FAD1409 (fig-forth-auto680):04081 INTER2 FDB DFIND,ZBRAN
4125+2123 001A (fig-forth-auto680):04082 FDB INTER5-*-NATWID
4126+2125 195817721A1D (fig-forth-auto680):04083 FDB STATE,AT,LESS
4127+212B 1409 (fig-forth-auto680):04084 FDB ZBRAN
4128+212D 0008 (fig-forth-auto680):04085 FDB INTER3-*-NATWID
4129+212F 1AEF19E313FA (fig-forth-auto680):04086 FDB CFA,COMMA,BRAN
4130+2135 0004 (fig-forth-auto680):04087 FDB INTER4-*-NATWID
4131+2137 1AEF13EB (fig-forth-auto680):04088 INTER3 FDB CFA,EXEC
4132+213B 13FA (fig-forth-auto680):04089 INTER4 FDB BRAN
4133+213D 0018 (fig-forth-auto680):04090 FDB INTER7-*-NATWID
4134+213F 19C71F57196D1772 (fig-forth-auto680):04091 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
4135+ 19AB1409
4136+214B 0006 (fig-forth-auto680):04092 FDB INTER6-*-NATWID
4137+214D 20FF13FA (fig-forth-auto680):04093 FDB DLITER,BRAN
4138+2151 0004 (fig-forth-auto680):04094 FDB INTER7-*-NATWID
4139+2153 172A20E2 (fig-forth-auto680):04095 INTER6 FDB DROP,LITER
4140+2157 1D5B13FA (fig-forth-auto680):04096 INTER7 FDB QSTACK,BRAN
4141+215B FFC2 (fig-forth-auto680):04097 FDB INTER2-*-NATWID
4142+ (fig-forth-auto680):04098 * FDB SEMIS never executed
4143+ (fig-forth-auto680):04099
4144+ (fig-forth-auto680):04100 *
4145+ (fig-forth-auto680):04101 * ######>> screen 54 <<
4146+ (fig-forth-auto680):04102 * ======>> 150 <<
4147+ (fig-forth-auto680):04103 * ( --- )
4148+ (fig-forth-auto680):04104 * Toggle precedence bit of LATEST definition header.
4149+ (fig-forth-auto680):04105 * During compiling, most symbols scanned are compiled.
4150+ (fig-forth-auto680):04106 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
4151+ (fig-forth-auto680):04107 * but may be compiled via ' (TICK).
4152+215D 89 (fig-forth-auto680):04108 FCB $89
4153+215E 494D4D4544494154 (fig-forth-auto680):04109 FCC 'IMMEDIAT' ; 'IMMEDIATE'
4154+2166 C5 (fig-forth-auto680):04110 FCB $C5
4155+2167 2111 (fig-forth-auto680):04111 FDB INTERP-12
4156+2169 17B91AD013A7 (fig-forth-auto680):04112 IMMED FDB DOCOL,LATEST,LIT8
4157+216F 40 (fig-forth-auto680):04113 FCB FIMMED
4158+2170 1765 (fig-forth-auto680):04114 FDB TOGGLE
4159+2172 1667 (fig-forth-auto680):04115 FDB SEMIS
4160+ (fig-forth-auto680):04116 *
4161+ (fig-forth-auto680):04117 * ======>> 151 <<
4162+ (fig-forth-auto680):04118 * ( --- ) { VOCABULARY name } input
4163+ (fig-forth-auto680):04119 * Create a vocabulary entry with a flag for terminating vocabulary searches.
4164+ (fig-forth-auto680):04120 * Store the current search context in it for linking.
4165+ (fig-forth-auto680):04121 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
4166+2174 8A (fig-forth-auto680):04122 FCB $8A
4167+2175 564F434142554C41 (fig-forth-auto680):04123 FCC 'VOCABULAR' ; 'VOCABULARY'
4168+ 52
4169+217E D9 (fig-forth-auto680):04124 FCB $D9
4170+217F 215D (fig-forth-auto680):04125 FDB IMMED-12
4171+2181 17B91C6A139981A0 (fig-forth-auto680):04126 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
4172+ 19E3194C17721AEF
4173+2191 19E319C718FC1772 (fig-forth-auto680):04127 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
4174+ 19E318FC178A1C7A
4175+ (fig-forth-auto680):04128 * DOVOC FDB TWOP,CONTXT,STORE
4176+21A1 1802193E178A (fig-forth-auto680):04129 DOVOC FDB NATP,CONTXT,STORE
4177+21A7 1667 (fig-forth-auto680):04130 FDB SEMIS
4178+ (fig-forth-auto680):04131 *
4179+ (fig-forth-auto680):04132 * ======>> 152 <<
4180+ (fig-forth-auto680):04133 *
4181+ (fig-forth-auto680):04134 * Note: FORTH does not go here in the rom-able dictionary,
4182+ (fig-forth-auto680):04135 * since FORTH is a type of variable.
4183+ (fig-forth-auto680):04136 *
4184+ (fig-forth-auto680):04137 * (Should make a proper architecture for this at some point.)
4185+ (fig-forth-auto680):04138 *
4186+ (fig-forth-auto680):04139 *
4187+ (fig-forth-auto680):04140 * ======>> 153 <<
4188+ (fig-forth-auto680):04141 * ( --- )
4189+ (fig-forth-auto680):04142 * Makes the current interpretation CONTEXT vocabulary
4190+ (fig-forth-auto680):04143 * also the CURRENT defining vocabulary.
4191+21A9 8B (fig-forth-auto680):04144 FCB $8B
4192+21AA 444546494E495449 (fig-forth-auto680):04145 FCC 'DEFINITION' ; 'DEFINITIONS'
4193+ 4F4E
4194+21B4 D3 (fig-forth-auto680):04146 FCB $D3
4195+21B5 2174 (fig-forth-auto680):04147 FDB VOCAB-13
4196+21B7 17B9193E1772194C (fig-forth-auto680):04148 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
4197+ 178A
4198+21C1 1667 (fig-forth-auto680):04149 FDB SEMIS
4199+ (fig-forth-auto680):04150 *
4200+ (fig-forth-auto680):04151 * ======>> 154 <<
4201+ (fig-forth-auto680):04152 * ( --- )
4202+ (fig-forth-auto680):04153 * Parse out a comment and toss it away.
4203+ (fig-forth-auto680):04154 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
4204+21C3 C1 (fig-forth-auto680):04155 FCB $C1 immediate (
4205+21C4 A8 (fig-forth-auto680):04156 FCB $A8
4206+21C5 21A9 (fig-forth-auto680):04157 FDB DEFIN-14
4207+21C7 17B913A7 (fig-forth-auto680):04158 PAREN FDB DOCOL,LIT8
4208+21CB 29 (fig-forth-auto680):04159 FCC ")"
4209+21CC 1EBC (fig-forth-auto680):04160 FDB WORD
4210+21CE 1667 (fig-forth-auto680):04161 FDB SEMIS
4211+ (fig-forth-auto680):04162 *
4212+ (fig-forth-auto680):04163 * ######>> screen 55 <<
4213+ (fig-forth-auto680):04164 * ======>> 155 <<
4214+ (fig-forth-auto680):04165 * ( anything *** nothing )
4215+ (fig-forth-auto680):04166 * Clear return stack.
4216+ (fig-forth-auto680):04167 * Then INTERPRET and, if not compiling, prompt with OK,
4217+ (fig-forth-auto680):04168 * in infinite loop.
4218+21D0 84 (fig-forth-auto680):04169 FCB $84
4219+21D1 515549 (fig-forth-auto680):04170 FCC 'QUI' ; 'QUIT'
4220+21D4 D4 (fig-forth-auto680):04171 FCB $D4
4221+21D5 21C3 (fig-forth-auto680):04172 FDB PAREN-4
4222+21D7 17B9183D1906178A (fig-forth-auto680):04173 QUIT FDB DOCOL,ZERO,BLK,STORE
4223+21DF 1BDD (fig-forth-auto680):04174 FDB LBRAK
4224+ (fig-forth-auto680):04175 *
4225+ (fig-forth-auto680):04176 * Here is the outer interpretter
4226+ (fig-forth-auto680):04177 * which gets a line of input, does it, prints " OK"
4227+ (fig-forth-auto680):04178 * then repeats :
4228+21E1 165815771DFF211D (fig-forth-auto680):04179 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
4229+ 1958177216A3
4230+21EF 1409 (fig-forth-auto680):04180 FDB ZBRAN
4231+21F1 0006 (fig-forth-auto680):04181 FDB QUIT3-*-NATWID
4232+21F3 1D10 (fig-forth-auto680):04182 FDB PDOTQ
4233+21F5 03 (fig-forth-auto680):04183 FCB 3
4234+21F6 204F4B (fig-forth-auto680):04184 FCC ' OK' ; ' OK'
4235+21F9 13FA (fig-forth-auto680):04185 QUIT3 FDB BRAN
4236+21FB FFE4 (fig-forth-auto680):04186 FDB QUIT2-*-NATWID
4237+ (fig-forth-auto680):04187 * FDB SEMIS ( never executed )
4238+ (fig-forth-auto680):04188 *
4239+ (fig-forth-auto680):04189 * ======>> 156 <<
4240+ (fig-forth-auto680):04190 * ( anything --- nothing ) ( anything *** nothing )
4241+ (fig-forth-auto680):04191 * Clear parameter stack,
4242+ (fig-forth-auto680):04192 * set STATE to interpret and BASE to DECIMAL,
4243+ (fig-forth-auto680):04193 * return to input from terminal,
4244+ (fig-forth-auto680):04194 * restore DRIVE OFFSET to 0,
4245+ (fig-forth-auto680):04195 * print out "Forth-68",
4246+ (fig-forth-auto680):04196 * set interpret and define vocabularies to FORTH,
4247+ (fig-forth-auto680):04197 * and finally, QUIT.
4248+ (fig-forth-auto680):04198 * Used to force the system to a known state
4249+ (fig-forth-auto680):04199 * and return control to the initial INTERPRETer.
4250+21FD 85 (fig-forth-auto680):04200 FCB $85
4251+21FE 41424F52 (fig-forth-auto680):04201 FCC 'ABOR' ; 'ABORT'
4252+2202 D4 (fig-forth-auto680):04202 FCB $D4
4253+2203 21D0 (fig-forth-auto680):04203 FDB QUIT-7
4254+2205 17B9164D1C251D5B (fig-forth-auto680):04204 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
4255+ 242515771D10
4256+2213 0A (fig-forth-auto680):04205 FCB 10
4257+2214 466F7274682D3638 (fig-forth-auto680):04206 FCC "Forth-6809"
4258+ 3039
4259+221E 2A9D21B7 (fig-forth-auto680):04207 FDB FORTH,DEFIN
4260+2222 21D7 (fig-forth-auto680):04208 FDB QUIT
4261+ (fig-forth-auto680):04209 * FDB SEMIS never executed
4262+ (fig-forth-auto680):04210 PAGE
4263+ (fig-forth-auto680):04211 *
4264+ (fig-forth-auto680):04212 * ######>> screen 56 <<
4265+ (fig-forth-auto680):04213 * bootstrap code... moves rom contents to ram :
4266+ (fig-forth-auto680):04214 * ======>> 157 <<
4267+2224 84 (fig-forth-auto680):04215 FCB $84
4268+2225 434F4C (fig-forth-auto680):04216 FCC 'COL' ; 'COLD'
4269+2228 C4 (fig-forth-auto680):04217 FCB $C4
4270+2229 21FD (fig-forth-auto680):04218 FDB ABORT-8
4271+222B 222D (fig-forth-auto680):04219 COLD FDB *+NATWID
4272+ (fig-forth-auto680):04220 * Ultimately, we want position indepence,
4273+ (fig-forth-auto680):04221 * so I'm using PCR where it seems reasonable.
4274+222D 10EE8DEFE0 (fig-forth-auto680):04222 CENT LDS SINIT,PCR ; Get a useable return stack, at least.
4275+2232 867C (fig-forth-auto680):04223 LDA #IUPDP ; This is not relative to PC.
4276+2234 1F8B (fig-forth-auto680):04224 TFR A,DP ; And a useable direct page, too.
4277+ 7C (fig-forth-auto680):04225 SETDP IUPDP ; (For good measure.)
4278+ (fig-forth-auto680):04226 *
4279+ (fig-forth-auto680):04227 * We'll keep this here for the time being.
4280+ (fig-forth-auto680):04228 * There are better ways to do this, of course.
4281+ (fig-forth-auto680):04229 * Re-architect, re-architect.
4282+2236 308D006A (fig-forth-auto680):04230 LEAX RAM,PCR
4283+223A 9F28 (fig-forth-auto680):04231 STX <XFENCE ; Borrow this variable for a loop terminator.
4284+223C 318D0890 (fig-forth-auto680):04232 LEAY REND,PCR ; top of destination
4285+2240 308D00A3 (fig-forth-auto680):04233 LEAX ERAM,PCR ; top of stuff to move
4286+2244 A682 (fig-forth-auto680):04234 COLD2 LDA ,-X
4287+2246 A7A2 (fig-forth-auto680):04235 STA ,-Y ; move TASK & FORTH to ram
4288+2248 9C28 (fig-forth-auto680):04236 CMPX <XFENCE
4289+224A 26F8 (fig-forth-auto680):04237 BNE COLD2
4290+ (fig-forth-auto680):04238 *
4291+ (fig-forth-auto680):04239 * CENT LDS #REND-1 top of destination
4292+ (fig-forth-auto680):04240 * LDX #ERAM top of stuff to move
4293+ (fig-forth-auto680):04241 * COLD2 LEAX -1,X ;
4294+ (fig-forth-auto680):04242 * LDA 0,X
4295+ (fig-forth-auto680):04243 * PSHS A ; move TASK & FORTH to ram
4296+ (fig-forth-auto680):04244 * CMPX #RAM
4297+ (fig-forth-auto680):04245 * BNE COLD2
4298+ (fig-forth-auto680):04246 *
4299+ (fig-forth-auto680):04247 * LDS #XFENCE-1 put stack at a safe place for now
4300+ (fig-forth-auto680):04248 * But that is taken care of.
4301+ (fig-forth-auto680):04249 * LDX COLINT
4302+ (fig-forth-auto680):04250 * STX XCOLUM
4303+224C AE8DEFD2 (fig-forth-auto680):04251 LDX COLINT,PCR
4304+2250 9F4C (fig-forth-auto680):04252 STX <XCOLUM
4305+ (fig-forth-auto680):04253 * LDX DELINT
4306+ (fig-forth-auto680):04254 * STX XDELAY
4307+2252 AE8DEFCE (fig-forth-auto680):04255 LDX DELINT,PCR
4308+2256 9F4A (fig-forth-auto680):04256 STX <XDELAY
4309+ (fig-forth-auto680):04257 * LDX VOCINT
4310+ (fig-forth-auto680):04258 * STX XVOCL
4311+2258 AE8DEFC4 (fig-forth-auto680):04259 LDX VOCINT,PCR
4312+225C 9F2C (fig-forth-auto680):04260 STX <XVOCL
4313+ (fig-forth-auto680):04261 * LDX DPINIT
4314+ (fig-forth-auto680):04262 * STX XDICTP
4315+225E AE8DEFBC (fig-forth-auto680):04263 LDX DPINIT,PCR
4316+2262 9F2A (fig-forth-auto680):04264 STX <XDICTP
4317+ (fig-forth-auto680):04265 * LDX FENCIN
4318+ (fig-forth-auto680):04266 * STX XFENCE
4319+2264 AE8DEFB4 (fig-forth-auto680):04267 LDX FENCIN,PCR
4320+2268 9F28 (fig-forth-auto680):04268 STX <XFENCE
4321+ (fig-forth-auto680):04269 *
4322+226A 10EE8DEFA3 (fig-forth-auto680):04270 WENT LDS SINIT,PCR ; Get a useable return stack, at least.
4323+226F 867C (fig-forth-auto680):04271 LDA #IUPDP ; This is not relative to PC.
4324+2271 1F8B (fig-forth-auto680):04272 TFR A,DP ; And a useable direct page, too.
4325+ 7C (fig-forth-auto680):04273 SETDP IUPDP ; (For good measure.)
4326+ (fig-forth-auto680):04274 *
4327+2273 308DEF9B (fig-forth-auto680):04275 LEAX SINIT,PCR
4328+2277 3410 (fig-forth-auto680):04276 PSHS X ; for loop termination
4329+2279 5F (fig-forth-auto680):04277 CLRB ; Yes, I'm being a little ridiculous. Only a little.
4330+227A 1F02 (fig-forth-auto680):04278 TFR D,Y
4331+227C 31A828 (fig-forth-auto680):04279 LEAY XFENCE-UORIG,Y ; top of destination
4332+227F 308DEF99 (fig-forth-auto680):04280 LEAX FENCIN,PCR ; top of stuff to move
4333+2283 EC83 (fig-forth-auto680):04281 WARM2 LDD ,--X ; All entries are 16 bit.
4334+2285 EDA3 (fig-forth-auto680):04282 STD ,--Y
4335+2287 ACE4 (fig-forth-auto680):04283 CMPX ,S
4336+2289 26F8 (fig-forth-auto680):04284 BNE WARM2
4337+228B 3262 (fig-forth-auto680):04285 LEAS 2,S ; But we'll reset the return stack shortly, anyway.
4338+ (fig-forth-auto680):04286 * WENT LDS #XFENCE-1 top of destination
4339+ (fig-forth-auto680):04287 * LDX #FENCIN top of stuff to move
4340+ (fig-forth-auto680):04288 * WARM2 LEAX -1,X ;
4341+ (fig-forth-auto680):04289 * LDA 0,X
4342+ (fig-forth-auto680):04290 * PSHS A ;
4343+ (fig-forth-auto680):04291 * CMPX #SINIT
4344+ (fig-forth-auto680):04292 * BNE WARM2
4345+ (fig-forth-auto680):04293 *
4346+ (fig-forth-auto680):04294 * LDS SINIT
4347+ (fig-forth-auto680):04295 * S is already there.
4348+ (fig-forth-auto680):04296 * LDX UPINIT
4349+ (fig-forth-auto680):04297 * STX UP init user ram pointer
4350+ (fig-forth-auto680):04298 * UP is already there (DP).
4351+ (fig-forth-auto680):04299 * LDX #ABORT
4352+ (fig-forth-auto680):04300 * STX IP
4353+228D 318DFF76 (fig-forth-auto680):04301 LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
4354+ (fig-forth-auto680):04302 *
4355+2291 12 (fig-forth-auto680):04303 NOP Here is a place to jump to special user
4356+2292 12 (fig-forth-auto680):04304 NOP initializations such as I/0 interrups
4357+2293 12 (fig-forth-auto680):04305 NOP
4358+ (fig-forth-auto680):04306 *
4359+ (fig-forth-auto680):04307 * For systems with TRACE:
4360+2294 8E0000 (fig-forth-auto680):04308 LDX #00
4361+ (fig-forth-auto680):04309 * STX TRLIM clear trace mode
4362+2297 9F0A (fig-forth-auto680):04310 STX <TRLIM clear trace mode (both bytes)
4363+2299 8E0000 (fig-forth-auto680):04311 LDX #0
4364+ (fig-forth-auto680):04312 * STX BRKPT clear breakpoint address
4365+229C 9F0C (fig-forth-auto680):04313 STX <BRKPT clear breakpoint address
4366+ (fig-forth-auto680):04314 * JMP RPSTOR+2 start the virtual machine running !
4367+229E 17F3B9 (fig-forth-auto680):04315 LBSR RPSTOR+NATWID start the virtual machine running !
4368+22A1 16EF84 (fig-forth-auto680):04316 LBRA NEXT ; But we must also give RP! someplace to return.
4369+ (fig-forth-auto680):04317 * RP! sets up the return stack pointer, then Y references abort.
4370+ (fig-forth-auto680):04318 *
4371+ (fig-forth-auto680):04319 * Here is the stuff that gets copied to ram :
4372+ (fig-forth-auto680):04320 * (not * at address $140:)
4373+ (fig-forth-auto680):04321 * at an appropriate address:
4374+ (fig-forth-auto680):04322 *
4375+22A4 3000300000000000 (fig-forth-auto680):04323 RAM FDB $3000,$3000,0,0
4376+ (fig-forth-auto680):04324
4377+ (fig-forth-auto680):04325 * ======>> (152) <<
4378+ (fig-forth-auto680):04326 * ( --- ) P
4379+ (fig-forth-auto680):04327 * Makes FORTH the current interpretation vocabulary.
4380+ (fig-forth-auto680):04328 * In order to make this ROMmable, this entry is set up as the tail-end,
4381+ (fig-forth-auto680):04329 * and copied to RAM in the start-up code.
4382+ (fig-forth-auto680):04330 * We want a more elegant solution to this, too. Greedy, maybe.
4383+22AC C5 (fig-forth-auto680):04331 FCB $C5 immediate
4384+22AD 464F5254 (fig-forth-auto680):04332 FCC 'FORT' ; 'FORTH'
4385+22B1 C8 (fig-forth-auto680):04333 FCB $C8
4386+22B2 2A7C (fig-forth-auto680):04334 FDB NOOP-7 ; Note that this does not link to COLD!
4387+22B4 1C8621A181A02AC5 (fig-forth-auto680):04335 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
4388+22BC 0000 (fig-forth-auto680):04336 FDB 0
4389+22BE 28432920466F7274 (fig-forth-auto680):04337 FCC "(C) Forth Interest Group, 1979"
4390+ 6820496E74657265
4391+ 73742047726F7570
4392+ 2C2031393739
4393+22DC 84 (fig-forth-auto680):04338 FCB $84
4394+22DD 544153 (fig-forth-auto680):04339 FCC 'TAS' ; 'TASK'
4395+22E0 CB (fig-forth-auto680):04340 FCB $CB
4396+22E1 2A95 (fig-forth-auto680):04341 FDB FORTH-8
4397+22E3 17B91667 (fig-forth-auto680):04342 RTASK FDB DOCOL,SEMIS
4398+22E7 4461766964204C69 (fig-forth-auto680):04343 ERAM FCC "David Lion"
4399+ 6F6E
4400+ (fig-forth-auto680):04344 PAGE
4401+ (fig-forth-auto680):04345 *
4402+ (fig-forth-auto680):04346 * ######>> screen 57 <<
4403+ (fig-forth-auto680):04347 * ======>> 158 <<
4404+ (fig-forth-auto680):04348 * ( n0 --- d0 )
4405+ (fig-forth-auto680):04349 * Sign extend n0 to a double integer.
4406+22F1 84 (fig-forth-auto680):04350 FCB $84
4407+22F2 532D3E (fig-forth-auto680):04351 FCC 'S->' ; 'S->D'
4408+22F5 C4 (fig-forth-auto680):04352 FCB $C4
4409+22F6 2224 (fig-forth-auto680):04353 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
4410+22F8 17B9174516B516EF (fig-forth-auto680):04354 STOD FDB DOCOL,DUP,ZLESS,MINUS
4411+2300 1667 (fig-forth-auto680):04355 FDB SEMIS
4412+ (fig-forth-auto680):04356
4413+ (fig-forth-auto680):04357
4414+ (fig-forth-auto680):04358 *
4415+ (fig-forth-auto680):04359 * ======>> 159 <<
4416+ (fig-forth-auto680):04360 * ( multiplier multiplicand --- product )
4417+ (fig-forth-auto680):04361 * Signed word multiply.
4418+2302 81 (fig-forth-auto680):04362 FCB $81 ; *
4419+2303 AA (fig-forth-auto680):04363 FCB $AA
4420+2304 22F1 (fig-forth-auto680):04364 FDB STOD-7
4421+2306 2308 (fig-forth-auto680):04365 STAR FDB *+NATWID
4422+2308 17F29C (fig-forth-auto680):04366 LBSR USTAR+NATWID ; or [USTAR,PCR]?
4423+230B 3342 (fig-forth-auto680):04367 LEAU NATWID,U ; Drop high word.
4424+230D 39 (fig-forth-auto680):04368 RTS
4425+ (fig-forth-auto680):04369 * JSR USTARS
4426+ (fig-forth-auto680):04370 * LEAS 1,S ;
4427+ (fig-forth-auto680):04371 * LEAS 1,S ;
4428+ (fig-forth-auto680):04372 * JMP NEXT
4429+ (fig-forth-auto680):04373 *
4430+ (fig-forth-auto680):04374 * ======>> 160 <<
4431+ (fig-forth-auto680):04375 * ( dividend divisor --- remainder quotient )
4432+ (fig-forth-auto680):04376 * M/ in word-only form, i. e., signed division of 2nd word by top word,
4433+ (fig-forth-auto680):04377 * yielding signed word quotient and remainder.
4434+230E 84 (fig-forth-auto680):04378 FCB $84
4435+230F 2F4D4F (fig-forth-auto680):04379 FCC '/MO' ; '/MOD'
4436+2312 C4 (fig-forth-auto680):04380 FCB $C4
4437+2313 2302 (fig-forth-auto680):04381 FDB STAR-4
4438+2315 17B9168122F81690 (fig-forth-auto680):04382 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
4439+ 15DB
4440+231F 1667 (fig-forth-auto680):04383 FDB SEMIS
4441+ (fig-forth-auto680):04384 *
4442+ (fig-forth-auto680):04385 * ======>> 161 <<
4443+ (fig-forth-auto680):04386 * ( dividend divisor --- quotient )
4444+ (fig-forth-auto680):04387 * Signed word divide without remainder.
4445+2321 81 (fig-forth-auto680):04388 FCB $81 ; /
4446+2322 AF (fig-forth-auto680):04389 FCB $AF
4447+2323 230E (fig-forth-auto680):04390 FDB SLMOD-7
4448+2325 17B923151736172A (fig-forth-auto680):04391 SLASH FDB DOCOL,SLMOD,SWAP,DROP
4449+232D 1667 (fig-forth-auto680):04392 FDB SEMIS
4450+ (fig-forth-auto680):04393 *
4451+ (fig-forth-auto680):04394 * ======>> 162 <<
4452+ (fig-forth-auto680):04395 * ( dividend divisor --- remainder )
4453+ (fig-forth-auto680):04396 * Remainder function, result takes sign of dividend.
4454+232F 83 (fig-forth-auto680):04397 FCB $83
4455+2330 4D4F (fig-forth-auto680):04398 FCC 'MO' ; 'MOD'
4456+2332 C4 (fig-forth-auto680):04399 FCB $C4
4457+2333 2321 (fig-forth-auto680):04400 FDB SLASH-4
4458+2335 17B92315172A (fig-forth-auto680):04401 MOD FDB DOCOL,SLMOD,DROP
4459+233B 1667 (fig-forth-auto680):04402 FDB SEMIS
4460+ (fig-forth-auto680):04403 *
4461+ (fig-forth-auto680):04404 * ======>> 163 <<
4462+ (fig-forth-auto680):04405 * ( multiplier multiplicand divisor --- remainder quotient )
4463+ (fig-forth-auto680):04406 * Signed precise division of product:
4464+ (fig-forth-auto680):04407 * multiply 2nd and 3rd words on stack
4465+ (fig-forth-auto680):04408 * and divide the 31-bit product by the top word,
4466+ (fig-forth-auto680):04409 * leaving both quotient and remainder.
4467+ (fig-forth-auto680):04410 * Remainder takes sign of product.
4468+ (fig-forth-auto680):04411 * Guaranteed not to lose significant bits in 16 bit integer math.
4469+233D 85 (fig-forth-auto680):04412 FCB $85
4470+233E 2A2F4D4F (fig-forth-auto680):04413 FCC '*/MO' ; '*/MOD'
4471+2342 C4 (fig-forth-auto680):04414 FCB $C4
4472+2343 232F (fig-forth-auto680):04415 FDB MOD-6
4473+2345 17B9168115A51690 (fig-forth-auto680):04416 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
4474+ 15DB
4475+234F 1667 (fig-forth-auto680):04417 FDB SEMIS
4476+ (fig-forth-auto680):04418 *
4477+ (fig-forth-auto680):04419 * ======>> 164 <<
4478+ (fig-forth-auto680):04420 * ( multiplier multiplicand divisor --- quotient )
4479+ (fig-forth-auto680):04421 * */MOD without remainder.
4480+2351 82 (fig-forth-auto680):04422 FCB $82
4481+2352 2A (fig-forth-auto680):04423 FCC '*' ; '*/'
4482+2353 AF (fig-forth-auto680):04424 FCB $AF
4483+2354 233D (fig-forth-auto680):04425 FDB SSMOD-8
4484+2356 17B923451736172A (fig-forth-auto680):04426 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
4485+235E 1667 (fig-forth-auto680):04427 FDB SEMIS
4486+ (fig-forth-auto680):04428 *
4487+ (fig-forth-auto680):04429 * ======>> 165 <<
4488+ (fig-forth-auto680):04430 * ( ud1 u1 --- u2 ud2 )
4489+ (fig-forth-auto680):04431 * U/ with an (unsigned) double quotient.
4490+ (fig-forth-auto680):04432 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
4491+ (fig-forth-auto680):04433 * if you are prepared to deal with the extra 16 bits of result.
4492+2360 85 (fig-forth-auto680):04434 FCB $85
4493+2361 4D2F4D4F (fig-forth-auto680):04435 FCC 'M/MO' ; 'M/MOD'
4494+2365 C4 (fig-forth-auto680):04436 FCB $C4
4495+2366 2351 (fig-forth-auto680):04437 FDB SSLASH-5
4496+2368 17B91681183D169C (fig-forth-auto680):04438 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
4497+ 15DB
4498+2372 16901736168115DB (fig-forth-auto680):04439 FDB FROMR,SWAP,TOR,USLASH,FROMR
4499+ 1690
4500+237C 1667 (fig-forth-auto680):04440 FDB SEMIS
4501+ (fig-forth-auto680):04441 *
4502+ (fig-forth-auto680):04442 * ======>> 166 <<
4503+ (fig-forth-auto680):04443 * ( n>=0 --- n )
4504+ (fig-forth-auto680):04444 * ( n<0 --- -n )
4505+ (fig-forth-auto680):04445 * Convert the top of stack to its absolute value.
4506+237E 83 (fig-forth-auto680):04446 FCB $83
4507+237F 4142 (fig-forth-auto680):04447 FCC 'AB' ; 'ABS'
4508+2381 D3 (fig-forth-auto680):04448 FCB $D3
4509+2382 2360 (fig-forth-auto680):04449 FDB MSMOD-8
4510+2384 17B9174516B51409 (fig-forth-auto680):04450 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
4511+238C 0002 (fig-forth-auto680):04451 FDB ABS2-*-NATWID
4512+238E 16EF (fig-forth-auto680):04452 FDB MINUS
4513+2390 1667 (fig-forth-auto680):04453 ABS2 FDB SEMIS
4514+ (fig-forth-auto680):04454 *
4515+ (fig-forth-auto680):04455 * ======>> 167 <<
4516+ (fig-forth-auto680):04456 * ( d>=0 --- d )
4517+ (fig-forth-auto680):04457 * ( d<0 --- -d )
4518+ (fig-forth-auto680):04458 * Convert the top double to its absolute value.
4519+2392 84 (fig-forth-auto680):04459 FCB $84
4520+2393 444142 (fig-forth-auto680):04460 FCC 'DAB' ; 'DABS'
4521+2396 D3 (fig-forth-auto680):04461 FCB $D3
4522+2397 237E (fig-forth-auto680):04462 FDB ABS-6
4523+2399 17B9174516B51409 (fig-forth-auto680):04463 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
4524+23A1 0002 (fig-forth-auto680):04464 FDB DABS2-*-NATWID
4525+23A3 1702 (fig-forth-auto680):04465 FDB DMINUS
4526+23A5 1667 (fig-forth-auto680):04466 DABS2 FDB SEMIS
4527+ (fig-forth-auto680):04467 *
4528+ (fig-forth-auto680):04468 * ######>> screen 58 <<
4529+ (fig-forth-auto680):04469 * Disc primitives :
4530+ (fig-forth-auto680):04470 * ======>> 168 <<
4531+ (fig-forth-auto680):04471 * ( --- vadr )
4532+ (fig-forth-auto680):04472 * Least Recently Used buffer.
4533+ (fig-forth-auto680):04473 * Really should be with FIRST and LIMIT in the per-task table.
4534+23A7 83 (fig-forth-auto680):04474 FCB $83
4535+23A8 5553 (fig-forth-auto680):04475 FCC 'US' ; 'USE'
4536+23AA C5 (fig-forth-auto680):04476 FCB $C5
4537+23AB 2392 (fig-forth-auto680):04477 FDB DABS-7
4538+23AD 17E9 (fig-forth-auto680):04478 USE FDB DOCON
4539+23AF 7C58 (fig-forth-auto680):04479 FDB XUSE
4540+ (fig-forth-auto680):04480 * ======>> 169 <<
4541+ (fig-forth-auto680):04481 * ( --- vadr )
4542+ (fig-forth-auto680):04482 * Most Recently Used buffer.
4543+ (fig-forth-auto680):04483 * Really should be with FIRST and LIMIT in the per-task table.
4544+23B1 84 (fig-forth-auto680):04484 FCB $84
4545+23B2 505245 (fig-forth-auto680):04485 FCC 'PRE' ; 'PREV'
4546+23B5 D6 (fig-forth-auto680):04486 FCB $D6
4547+23B6 23A7 (fig-forth-auto680):04487 FDB USE-6
4548+23B8 17E9 (fig-forth-auto680):04488 PREV FDB DOCON
4549+23BA 7C5A (fig-forth-auto680):04489 FDB XPREV
4550+ (fig-forth-auto680):04490 * ======>> 170 <<
4551+ (fig-forth-auto680):04491 * ( buffer1 --- buffer2 f )
4552+ (fig-forth-auto680):04492 * Bump to next buffer,
4553+ (fig-forth-auto680):04493 * flag false if result is PREVious buffer,
4554+ (fig-forth-auto680):04494 * otherwise flag true.
4555+ (fig-forth-auto680):04495 * Used in the LRU allocation routines.
4556+23BC 84 (fig-forth-auto680):04496 FCB $84
4557+23BD 2B4255 (fig-forth-auto680):04497 FCC '+BU' ; '+BUF'
4558+23C0 C6 (fig-forth-auto680):04498 FCB $C6
4559+23C1 23B1 (fig-forth-auto680):04499 FDB PREV-7
4560+23C3 17B913A7 (fig-forth-auto680):04500 PBUF FDB DOCOL,LIT8
4561+23C7 84 (fig-forth-auto680):04501 FCB $84
4562+23C8 16C6174518761A11 (fig-forth-auto680):04502 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
4563+ 1409
4564+23D2 0004 (fig-forth-auto680):04503 FDB PBUF2-*-NATWID
4565+23D4 172A186A (fig-forth-auto680):04504 FDB DROP,FIRST
4566+23D8 174523B817721A04 (fig-forth-auto680):04505 PBUF2 FDB DUP,PREV,AT,SUB
4567+23E0 1667 (fig-forth-auto680):04506 FDB SEMIS
4568+ (fig-forth-auto680):04507 *
4569+ (fig-forth-auto680):04508 * ======>> 171 <<
4570+ (fig-forth-auto680):04509 * ( --- )
4571+ (fig-forth-auto680):04510 * Mark PREVious buffer dirty, in need of being written out.
4572+23E2 86 (fig-forth-auto680):04511 FCB $86
4573+23E3 5550444154 (fig-forth-auto680):04512 FCC 'UPDAT' ; 'UPDATE'
4574+23E8 C5 (fig-forth-auto680):04513 FCB $C5
4575+23E9 23BC (fig-forth-auto680):04514 FDB PBUF-7
4576+23EB 17B923B817721772 (fig-forth-auto680):04515 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
4577+ 13998000161E23B8
4578+ 1772178A
4579+23FF 1667 (fig-forth-auto680):04516 FDB SEMIS
4580+ (fig-forth-auto680):04517 *
4581+ (fig-forth-auto680):04518 * ======>> 172 <<
4582+ (fig-forth-auto680):04519 * ( --- )
4583+ (fig-forth-auto680):04520 * Mark all buffers empty.
4584+ (fig-forth-auto680):04521 * Standard method of discarding changes.
4585+2401 8D (fig-forth-auto680):04522 FCB $8D
4586+2402 454D5054592D4255 (fig-forth-auto680):04523 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
4587+ 46464552
4588+240E D3 (fig-forth-auto680):04524 FCB $D3
4589+240F 23E2 (fig-forth-auto680):04525 FDB UPDATE-9
4590+2411 17B9186A1876171C (fig-forth-auto680):04526 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
4591+ 1A041E72
4592+241D 1667 (fig-forth-auto680):04527 FDB SEMIS
4593+ (fig-forth-auto680):04528 *
4594+ (fig-forth-auto680):04529 * ======>> 173 <<
4595+ (fig-forth-auto680):04530 * ( --- )
4596+ (fig-forth-auto680):04531 * Clear the current offset to the block numbers in the drive interface.
4597+ (fig-forth-auto680):04532 * The drives need to be re-architected.
4598+ (fig-forth-auto680):04533 * Would be cool to have RAM and ROM drives supported
4599+ (fig-forth-auto680):04534 * in addition to regular physical persistent store.
4600+241F 83 (fig-forth-auto680):04535 FCB $83
4601+2420 4452 (fig-forth-auto680):04536 FCC 'DR' ; 'DR0'
4602+2422 B0 (fig-forth-auto680):04537 FCB $B0
4603+2423 2401 (fig-forth-auto680):04538 FDB MTBUF-16
4604+2425 17B9183D1930178A (fig-forth-auto680):04539 DRZERO FDB DOCOL,ZERO,OFSET,STORE
4605+242D 1667 (fig-forth-auto680):04540 FDB SEMIS
4606+ (fig-forth-auto680):04541 *
4607+ (fig-forth-auto680):04542 * ======>> 174 <<== system dependant word
4608+ (fig-forth-auto680):04543 * ( --- )
4609+ (fig-forth-auto680):04544 * Set the current offset in the drive interface to reference the second drive.
4610+ (fig-forth-auto680):04545 * The hard-coded number in there needs to be in a table.
4611+242F 83 (fig-forth-auto680):04546 FCB $83
4612+2430 4452 (fig-forth-auto680):04547 FCC 'DR' ; 'DR1'
4613+2432 B1 (fig-forth-auto680):04548 FCB $B1
4614+2433 241F (fig-forth-auto680):04549 FDB DRZERO-6
4615+2435 17B9139907D01930 (fig-forth-auto680):04550 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
4616+ 178A
4617+243F 1667 (fig-forth-auto680):04551 FDB SEMIS
4618+ (fig-forth-auto680):04552 *
4619+ (fig-forth-auto680):04553 * ######>> screen 59 <<
4620+ (fig-forth-auto680):04554 * ======>> 175 <<
4621+ (fig-forth-auto680):04555 * ( n --- buffer )
4622+ (fig-forth-auto680):04556 * Get a free buffer,
4623+ (fig-forth-auto680):04557 * assign it to block n,
4624+ (fig-forth-auto680):04558 * return buffer address.
4625+ (fig-forth-auto680):04559 * Will free a buffer by writing it, if necessary.
4626+ (fig-forth-auto680):04560 * Does not actually read the block.
4627+ (fig-forth-auto680):04561 * A bug in the fig LRU algorithm, which I have not fixed,
4628+ (fig-forth-auto680):04562 * gives the PREVious buffer if USE gets set to PREVious.
4629+ (fig-forth-auto680):04563 * (The bug is that USE sometimes gets set to PREVious.)
4630+ (fig-forth-auto680):04564 * This bug sometimes causes sector moves to become sector fills.
4631+2441 86 (fig-forth-auto680):04565 FCB $86
4632+2442 4255464645 (fig-forth-auto680):04566 FCC 'BUFFE' ; 'BUFFER'
4633+2447 D2 (fig-forth-auto680):04567 FCB $D2
4634+2448 242F (fig-forth-auto680):04568 FDB DRONE-6
4635+244A 17B923AD17721745 (fig-forth-auto680):04569 BUFFER FDB DOCOL,USE,AT,DUP,TOR
4636+ 1681
4637+2454 23C31409 (fig-forth-auto680):04570 BUFFR2 FDB PBUF,ZBRAN
4638+2458 FFFA (fig-forth-auto680):04571 FDB BUFFR2-*-NATWID
4639+245A 23AD178A169C1772 (fig-forth-auto680):04572 FDB USE,STORE,R,AT,ZLESS
4640+ 16B5
4641+2464 1409 (fig-forth-auto680):04573 FDB ZBRAN
4642+2466 0012 (fig-forth-auto680):04574 FDB BUFFR3-*-NATWID
4643+ (fig-forth-auto680):04575 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
4644+2468 169C1802169C1772 (fig-forth-auto680):04576 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
4645+ 13997FFF160E183D
4646+ 263B
4647+ (fig-forth-auto680):04577 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
4648+247A 169C178A169C23B8 (fig-forth-auto680):04578 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
4649+ 178A16901802
4650+2488 1667 (fig-forth-auto680):04579 FDB SEMIS
4651+ (fig-forth-auto680):04580 *
4652+ (fig-forth-auto680):04581 * ######>> screen 60 <<
4653+ (fig-forth-auto680):04582 * ======>> 176 <<
4654+ (fig-forth-auto680):04583 * ( n --- buffer )
4655+ (fig-forth-auto680):04584 * Get BUFFER containing block n, relative to OFFSET.
4656+ (fig-forth-auto680):04585 * If block n is not in a buffer, bring it in.
4657+ (fig-forth-auto680):04586 * Returns buffer address.
4658+248A 85 (fig-forth-auto680):04587 FCB $85
4659+248B 424C4F43 (fig-forth-auto680):04588 FCC 'BLOC' ; 'BLOCK'
4660+248F CB (fig-forth-auto680):04589 FCB $CB
4661+2490 2441 (fig-forth-auto680):04590 FDB BUFFER-9
4662+2492 17B91930177216C6 (fig-forth-auto680):04591 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
4663+ 1681
4664+249C 23B8177217451772 (fig-forth-auto680):04592 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
4665+ 169C1A04174516C6
4666+ 1409
4667+24AE 0032 (fig-forth-auto680):04593 FDB BLOCK5-*-NATWID
4668+24B0 23C316A31409 (fig-forth-auto680):04594 BLOCK3 FDB PBUF,ZEQU,ZBRAN
4669+24B6 0012 (fig-forth-auto680):04595 FDB BLOCK4-*-NATWID
4670+ (fig-forth-auto680):04596 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
4671+24B8 172A169C244A1745 (fig-forth-auto680):04597 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
4672+ 169C1845263B17F7
4673+ 1A04
4674+24CA 17451772169C1A04 (fig-forth-auto680):04598 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
4675+ 174516C616A31409
4676+24DA FFD4 (fig-forth-auto680):04599 FDB BLOCK3-*-NATWID
4677+24DC 174523B8178A (fig-forth-auto680):04600 FDB DUP,PREV,STORE
4678+ (fig-forth-auto680):04601 * BLOCK5 FDB FROMR,DROP,TWOP
4679+24E2 1690172A1802 (fig-forth-auto680):04602 BLOCK5 FDB FROMR,DROP,NATP
4680+24E8 1667 (fig-forth-auto680):04603 FDB SEMIS
4681+ (fig-forth-auto680):04604 *
4682+ (fig-forth-auto680):04605 * ######>> screen 61 <<
4683+ (fig-forth-auto680):04606 * ======>> 177 <<
4684+ (fig-forth-auto680):04607 * ( line screen --- buffer C/L)
4685+ (fig-forth-auto680):04608 * Bring in the sector containing the specified line of the specified screen.
4686+ (fig-forth-auto680):04609 * Returns the buffer address and the width of the screen.
4687+ (fig-forth-auto680):04610 * Screen number is relative to OFFSET.
4688+ (fig-forth-auto680):04611 * The line number may be beyond screen 4,
4689+ (fig-forth-auto680):04612 * (LINE) will get the appropriate screen.
4690+24EA 86 (fig-forth-auto680):04613 FCB $86
4691+24EB 284C494E45 (fig-forth-auto680):04614 FCC '(LINE' ; '(LINE)'
4692+24F0 A9 (fig-forth-auto680):04615 FCB $A9
4693+24F1 248A (fig-forth-auto680):04616 FDB BLOCK-8
4694+24F3 17B9168113A7 (fig-forth-auto680):04617 PLINE FDB DOCOL,TOR,LIT8
4695+24F9 40 (fig-forth-auto680):04618 FCB $40
4696+24FA 188223451690188E (fig-forth-auto680):04619 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
4697+ 230616C6249216C6
4698+ 13A7
4699+250C 40 (fig-forth-auto680):04620 FCB $40
4700+250D 1667 (fig-forth-auto680):04621 FDB SEMIS
4701+ (fig-forth-auto680):04622 *
4702+ (fig-forth-auto680):04623 * ======>> 178 <<
4703+ (fig-forth-auto680):04624 * ( line screen --- )
4704+ (fig-forth-auto680):04625 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
4705+250F 85 (fig-forth-auto680):04626 FCB $85
4706+2510 2E4C494E (fig-forth-auto680):04627 FCC '.LIN' ; '.LINE'
4707+2514 C5 (fig-forth-auto680):04628 FCB $C5
4708+2515 24EA (fig-forth-auto680):04629 FDB PLINE-9
4709+2517 17B924F31CDD1CAF (fig-forth-auto680):04630 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
4710+251F 1667 (fig-forth-auto680):04631 FDB SEMIS
4711+ (fig-forth-auto680):04632 *
4712+ (fig-forth-auto680):04633 * ======>> 179 <<
4713+ (fig-forth-auto680):04634 * ( n --- )
4714+ (fig-forth-auto680):04635 * If WARNING is 0, print "MESSAGE #n";
4715+ (fig-forth-auto680):04636 * otherwise, print line n relative to screen 4,
4716+ (fig-forth-auto680):04637 * the line number may be negative.
4717+ (fig-forth-auto680):04638 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
4718+2521 87 (fig-forth-auto680):04639 FCB $87
4719+2522 4D4553534147 (fig-forth-auto680):04640 FCC 'MESSAG' ; 'MESSAGE'
4720+2528 C5 (fig-forth-auto680):04641 FCB $C5
4721+2529 250F (fig-forth-auto680):04642 FDB DLINE-8
4722+252B 17B918D817721409 (fig-forth-auto680):04643 MESS FDB DOCOL,WARN,AT,ZBRAN
4723+2533 0019 (fig-forth-auto680):04644 FDB MESS3-*-NATWID
4724+2535 1A8A1409 (fig-forth-auto680):04645 FDB DDUP,ZBRAN
4725+2539 0013 (fig-forth-auto680):04646 FDB MESS3-*-NATWID
4726+253B 13A7 (fig-forth-auto680):04647 FDB LIT8
4727+253D 04 (fig-forth-auto680):04648 FCB 4
4728+253E 19301772188E2325 (fig-forth-auto680):04649 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
4729+ 1A04251713FA
4730+254C 000B (fig-forth-auto680):04650 FDB MESS4-*-NATWID
4731+254E 1D10 (fig-forth-auto680):04651 MESS3 FDB PDOTQ
4732+2550 06 (fig-forth-auto680):04652 FCB 6
4733+2551 657272202320 (fig-forth-auto680):04653 FCC 'err # ' ; 'err # '
4734+2557 28D6 (fig-forth-auto680):04654 FDB DOT
4735+2559 1667 (fig-forth-auto680):04655 MESS4 FDB SEMIS
4736+ (fig-forth-auto680):04656 *
4737+ (fig-forth-auto680):04657 * ======>> 180 <<
4738+ (fig-forth-auto680):04658 * ( n --- )
4739+ (fig-forth-auto680):04659 * Begin interpretation of screen (block) n.
4740+ (fig-forth-auto680):04660 * See also ARROW, SEMIS, and NULL.
4741+255B 84 (fig-forth-auto680):04661 FCB $84
4742+255C 4C4F41 (fig-forth-auto680):04662 FCC 'LOA' ; 'LOAD' : input:scr #
4743+255F C4 (fig-forth-auto680):04663 FCB $C4
4744+2560 2521 (fig-forth-auto680):04664 FDB MESS-10
4745+2562 17B9190617721681 (fig-forth-auto680):04665 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
4746+ 190F17721681183D
4747+ 190F178A
4748+2576 188E23061906178A (fig-forth-auto680):04666 FDB BSCR,STAR,BLK,STORE
4749+257E 211D1690190F178A (fig-forth-auto680):04667 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
4750+ 16901906178A
4751+258C 1667 (fig-forth-auto680):04668 FDB SEMIS
4752+ (fig-forth-auto680):04669 *
4753+ (fig-forth-auto680):04670 * ======>> 181 <<
4754+ (fig-forth-auto680):04671 * ( --- ) P
4755+ (fig-forth-auto680):04672 * Continue interpreting source code on the next screen.
4756+258E C3 (fig-forth-auto680):04673 FCB $C3
4757+258F 2D2D (fig-forth-auto680):04674 FCC '--' ; '-->'
4758+2591 BE (fig-forth-auto680):04675 FCB $BE
4759+2592 255B (fig-forth-auto680):04676 FDB LOAD-7
4760+2594 17B91BAE183D190F (fig-forth-auto680):04677 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
4761+ 178A188E
4762+25A0 19061772171C2335 (fig-forth-auto680):04678 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
4763+ 1A0419061751
4764+25AE 1667 (fig-forth-auto680):04679 FDB SEMIS
4765+ (fig-forth-auto680):04680 PAGE
4766+ (fig-forth-auto680):04681 *
4767+ (fig-forth-auto680):04682 *
4768+ (fig-forth-auto680):04683 * ######>> screen 63 <<
4769+ (fig-forth-auto680):04684 * The next 4 subroutines are machine dependent, and are
4770+ (fig-forth-auto680):04685 * called by words 13 through 16 in the dictionary.
4771+ (fig-forth-auto680):04686 *
4772+ (fig-forth-auto680):04687 * ======>> 182 << code for EMIT
4773+ (fig-forth-auto680):04688 * ( --- ) No parameter stack effect.
4774+ (fig-forth-auto680):04689 * Interfaces directly with ROM. Expects output character in D (therefore, B).
4775+ (fig-forth-auto680):04690 * Output using rom CHROUT: redirectable to a printer on Coco.
4776+ (fig-forth-auto680):04691 * Outputs the character on stack (low byte of 1 bit word/cell).
4777+25B0 3468 (fig-forth-auto680):04692 PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
4778+25B2 1F98 (fig-forth-auto680):04693 TFR B,A ; Coco ROM wants it in A.
4779+25B4 5F (fig-forth-auto680):04694 CLRB
4780+25B5 1F9B (fig-forth-auto680):04695 TFR B,DP ; Give the ROM its direct page.
4781+25B7 AD9FA002 (fig-forth-auto680):04696 JSR [$A002] ; Output the character in A.
4782+25BB 35E8 (fig-forth-auto680):04697 PULS Y,U,DP,PC
4783+ (fig-forth-auto680):04698 * PEMIT STB N save B
4784+ (fig-forth-auto680):04699 * STX N+1 save X
4785+ (fig-forth-auto680):04700 * LDB ACIAC
4786+ (fig-forth-auto680):04701 * BITB #2 check ready bit
4787+ (fig-forth-auto680):04702 * BEQ PEMIT+4 if not ready for more data
4788+ (fig-forth-auto680):04703 * STA ACIAD
4789+ (fig-forth-auto680):04704 * LDX UP
4790+ (fig-forth-auto680):04705 * STB IOSTAT-UORIG,X
4791+ (fig-forth-auto680):04706 * LDB N recover B & X
4792+ (fig-forth-auto680):04707 * LDX N+1
4793+ (fig-forth-auto680):04708 * RTS only A register may change
4794+ (fig-forth-auto680):04709 * PEMIT JMP $E1D1 for MIKBUG
4795+ (fig-forth-auto680):04710 * PEMIT FCB $3F,$11,$39 for PROTO
4796+ (fig-forth-auto680):04711 * PEMIT JMP $D286 for Smoke Signal DOS
4797+ (fig-forth-auto680):04712 *
4798+ (fig-forth-auto680):04713 * ======>> 183 << code for KEY
4799+ (fig-forth-auto680):04714 * ( --- ) No parameter stack effect.
4800+ (fig-forth-auto680):04715 * Returns character or break flag in D, since this interfaces with Coco ROM.
4801+ (fig-forth-auto680):04716 * Wait for key from POLCAT on Coco.
4802+ (fig-forth-auto680):04717 * Returns the character code for the key pressed.
4803+25BD 3468 (fig-forth-auto680):04718 PKEY PSHS Y,U,DP ; Must save everything important for this one.
4804+25BF 86CF (fig-forth-auto680):04719 LDA #$CF ; a cursor of sorts
4805+25C1 5F (fig-forth-auto680):04720 CLRB
4806+25C2 1F9B (fig-forth-auto680):04721 TFR B,DP
4807+ 00 (fig-forth-auto680):04722 SETDP 0
4808+25C4 9E88 (fig-forth-auto680):04723 LDX <$88 ; location
4809+25C6 E684 (fig-forth-auto680):04724 LDB ,X ; save glyph
4810+25C8 A784 (fig-forth-auto680):04725 STA ,X
4811+25CA AD9FA000 (fig-forth-auto680):04726 PKEYLP JSR [$A000]
4812+25CE B7041A (fig-forth-auto680):04727 STA $41A ; DBG!
4813+25D1 27F7 (fig-forth-auto680):04728 BEQ PKEYLP
4814+25D3 FD0418 (fig-forth-auto680):04729 STD $418 ; DBG!
4815+25D6 E784 (fig-forth-auto680):04730 STB ,X ; restore
4816+25D8 5F (fig-forth-auto680):04731 PKEYR CLRB ; for the break flag, shares code with PQTER
4817+25D9 8103 (fig-forth-auto680):04732 CMPA #3 ; break key
4818+25DB 2601 (fig-forth-auto680):04733 BNE PKEYGT
4819+25DD 53 (fig-forth-auto680):04734 COMB ; for the break flag
4820+25DE 1E89 (fig-forth-auto680):04735 PKEYGT EXG A,B ; Leave it in D for return.
4821+25E0 35E8 (fig-forth-auto680):04736 PULS Y,U,DP,PC ; Shares exit with PQTER
4822+ 7C (fig-forth-auto680):04737 SETDP IUPDP
4823+ (fig-forth-auto680):04738 * PKEY STB N
4824+ (fig-forth-auto680):04739 * STX N+1
4825+ (fig-forth-auto680):04740 * LDB ACIAC
4826+ (fig-forth-auto680):04741 * ASRB ;
4827+ (fig-forth-auto680):04742 * BCC PKEY+4 no incoming data yet
4828+ (fig-forth-auto680):04743 * LDA ACIAD
4829+ (fig-forth-auto680):04744 * ANDA #$7F strip parity bit
4830+ (fig-forth-auto680):04745 * LDX UP
4831+ (fig-forth-auto680):04746 * STB IOSTAT+1-UORIG,X
4832+ (fig-forth-auto680):04747 * LDB N
4833+ (fig-forth-auto680):04748 * LDX N+1
4834+ (fig-forth-auto680):04749 * RTS
4835+ (fig-forth-auto680):04750 * PKEY JMP $E1AC for MIKBUG
4836+ (fig-forth-auto680):04751 * PKEY FCB $3F,$14,$39 for PROTO
4837+ (fig-forth-auto680):04752 * PKEY JMP $D289 for Smoke Signal DOS
4838+ (fig-forth-auto680):04753 *
4839+ (fig-forth-auto680):04754 * ######>> screen 64 <<
4840+ (fig-forth-auto680):04755 * ======>> 184 << code for ?TERMINAL
4841+ (fig-forth-auto680):04756 * ( --- f ) Should change this to no stack effect.
4842+ (fig-forth-auto680):04757 * check break key using POLCAT
4843+ (fig-forth-auto680):04758 * Returns a flag to tell whether the break key was pressed or not.
4844+25E2 3468 (fig-forth-auto680):04759 PQTER PSHS Y,U,DP
4845+25E4 5F (fig-forth-auto680):04760 CLRB
4846+25E5 1F9B (fig-forth-auto680):04761 TFR B,DP
4847+25E7 AD9FA000 (fig-forth-auto680):04762 JSR [$A000] ; Look but don't wait.
4848+25EB 20EB (fig-forth-auto680):04763 BRA PKEYR
4849+ (fig-forth-auto680):04764 * PQTER LDA ACIAC Test for 'break' condition
4850+ (fig-forth-auto680):04765 * ANDA #$11 mask framing error bit and
4851+ (fig-forth-auto680):04766 * input buffer full
4852+ (fig-forth-auto680):04767 * BEQ PQTER2
4853+ (fig-forth-auto680):04768 * LDA ACIAD clear input buffer
4854+ (fig-forth-auto680):04769 * LDA #01
4855+ (fig-forth-auto680):04770 * PQTER2 RTS
4856+ (fig-forth-auto680):04771
4857+ (fig-forth-auto680):04772
4858+ (fig-forth-auto680):04773 PAGE
4859+ (fig-forth-auto680):04774 *
4860+ (fig-forth-auto680):04775 * ======>> 185 << code for CR
4861+ (fig-forth-auto680):04776 * ( --- ) No stack effect.
4862+ (fig-forth-auto680):04777 * Interfaces directly with ROM.
4863+ (fig-forth-auto680):04778 * For Coco just output a CR.
4864+ (fig-forth-auto680):04779 * Also subject to redirection in Coco BASIC ROM.
4865+25ED C60D (fig-forth-auto680):04780 PCR LDB #$0D
4866+25EF 20BF (fig-forth-auto680):04781 BRA PEMIT ; Just steal the code.
4867+ (fig-forth-auto680):04782 * PCR LDA #$D carriage return
4868+ (fig-forth-auto680):04783 * BSR PEMIT
4869+ (fig-forth-auto680):04784 * LDA #$A line feed
4870+ (fig-forth-auto680):04785 * BSR PEMIT
4871+ (fig-forth-auto680):04786 * LDA #$7F rubout
4872+ (fig-forth-auto680):04787 * LDX UP
4873+ (fig-forth-auto680):04788 * LDB XDELAY+1-UORIG,X
4874+ (fig-forth-auto680):04789 * PCR2 DECB ;
4875+ (fig-forth-auto680):04790 * BMI PQTER2 return if minus
4876+ (fig-forth-auto680):04791 * PSHS B ; save counter
4877+ (fig-forth-auto680):04792 * BSR PEMIT print RUBOUTs to delay.....
4878+ (fig-forth-auto680):04793 * PULS B ;
4879+ (fig-forth-auto680):04794 * BRA PCR2 repeat
4880+ (fig-forth-auto680):04795
4881+ (fig-forth-auto680):04796
4882+ (fig-forth-auto680):04797 PAGE
4883+ (fig-forth-auto680):04798 *
4884+ (fig-forth-auto680):04799 * ######>> screen 66 <<
4885+ (fig-forth-auto680):04800 * ======>> 187 <<
4886+ (fig-forth-auto680):04801 * ( ??? )
4887+ (fig-forth-auto680):04802 * Query the disk, I suppose.
4888+ (fig-forth-auto680):04803 * Not sure what the model had in mind for this stub.
4889+25F1 85 (fig-forth-auto680):04804 FCB $85
4890+25F2 3F444953 (fig-forth-auto680):04805 FCC '?DIS' ; '?DISC'
4891+25F6 C3 (fig-forth-auto680):04806 FCB $C3
4892+25F7 258E (fig-forth-auto680):04807 FDB ARROW-6
4893+25F9 25FB (fig-forth-auto680):04808 QDISC FDB *+NATWID
4894+25FB 7E1228 (fig-forth-auto680):04809 JMP NEXT
4895+ (fig-forth-auto680):04810 *
4896+ (fig-forth-auto680):04811 * ######>> screen 67 <<
4897+ (fig-forth-auto680):04812 * ======>> 189 <<
4898+ (fig-forth-auto680):04813 * ( ??? )
4899+ (fig-forth-auto680):04814 * Write one block of data to disk.
4900+ (fig-forth-auto680):04815 * Parameters unspecified in model. Stub in model.
4901+25FE 8B (fig-forth-auto680):04816 FCB $8B
4902+25FF 424C4F434B2D5752 (fig-forth-auto680):04817 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
4903+ 4954
4904+2609 C5 (fig-forth-auto680):04818 FCB $C5
4905+260A 25F1 (fig-forth-auto680):04819 FDB QDISC-8
4906+260C 260E (fig-forth-auto680):04820 BWRITE FDB *+NATWID
4907+260E 7E1228 (fig-forth-auto680):04821 JMP NEXT
4908+ (fig-forth-auto680):04822 *
4909+ (fig-forth-auto680):04823 * ######>> screen 68 <<
4910+ (fig-forth-auto680):04824 * ======>> 190 <<
4911+ (fig-forth-auto680):04825 * ( ??? )
4912+ (fig-forth-auto680):04826 * Read one block of data from disk.
4913+ (fig-forth-auto680):04827 * Parameters unspecified in model. Stub in model.
4914+2611 8A (fig-forth-auto680):04828 FCB $8A
4915+2612 424C4F434B2D5245 (fig-forth-auto680):04829 FCC 'BLOCK-REA' ; 'BLOCK-READ'
4916+ 41
4917+261B C4 (fig-forth-auto680):04830 FCB $C4
4918+261C 25FE (fig-forth-auto680):04831 FDB BWRITE-14
4919+261E 2620 (fig-forth-auto680):04832 BREAD FDB *+NATWID
4920+2620 7E1228 (fig-forth-auto680):04833 JMP NEXT
4921+ (fig-forth-auto680):04834 *
4922+ (fig-forth-auto680):04835 *The next 3 words are written to create a substitute for disc
4923+ (fig-forth-auto680):04836 * mass memory,located between $3210 & $3FFF in ram.
4924+ (fig-forth-auto680):04837 * ======>> 190.1 <<
4925+2623 82 (fig-forth-auto680):04838 FCB $82
4926+2624 4C (fig-forth-auto680):04839 FCC 'L' ; 'LO'
4927+2625 CF (fig-forth-auto680):04840 FCB $CF
4928+2626 2611 (fig-forth-auto680):04841 FDB BREAD-13
4929+2628 17E9 (fig-forth-auto680):04842 LO FDB DOCON
4930+262A 7000 (fig-forth-auto680):04843 FDB MEMEND a system dependent equate at front
4931+ (fig-forth-auto680):04844 *
4932+ (fig-forth-auto680):04845 * ======>> 190.2 <<
4933+262C 82 (fig-forth-auto680):04846 FCB $82
4934+262D 48 (fig-forth-auto680):04847 FCC 'H' ; 'HI'
4935+262E C9 (fig-forth-auto680):04848 FCB $C9
4936+262F 2623 (fig-forth-auto680):04849 FDB LO-5
4937+2631 17E9 (fig-forth-auto680):04850 HI FDB DOCON
4938+2633 7FFF (fig-forth-auto680):04851 FDB MEMTOP ( $3FFF or $7FFF in this version )
4939+ (fig-forth-auto680):04852 *
4940+ (fig-forth-auto680):04853 * ######>> screen 69 <<
4941+ (fig-forth-auto680):04854 * ======>> 191 <<
4942+ (fig-forth-auto680):04855 * ( buffer sector f --- )
4943+ (fig-forth-auto680):04856 * Read or Write the specified (absolute -- ignores OFFSET) sector
4944+ (fig-forth-auto680):04857 * from or to the specified buffer.
4945+ (fig-forth-auto680):04858 * A zero flag specifies write,
4946+ (fig-forth-auto680):04859 * non-zero specifies read.
4947+ (fig-forth-auto680):04860 * Sector is an unsigned integer,
4948+ (fig-forth-auto680):04861 * buffer is the buffer's address.
4949+ (fig-forth-auto680):04862 * Will need to use the CoCo ROM disk routines.
4950+ (fig-forth-auto680):04863 * For now, provides a virtual disk in RAM.
4951+2635 83 (fig-forth-auto680):04864 FCB $83
4952+2636 522F (fig-forth-auto680):04865 FCC 'R/' ; 'R/W'
4953+2638 D7 (fig-forth-auto680):04866 FCB $D7
4954+2639 262C (fig-forth-auto680):04867 FDB HI-5
4955+263B 17B9168118822306 (fig-forth-auto680):04868 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
4956+ 262816C617452631
4957+ 1A351409
4958+264F 000D (fig-forth-auto680):04869 FDB RW2-*-NATWID
4959+2651 1D10 (fig-forth-auto680):04870 FDB PDOTQ
4960+2653 08 (fig-forth-auto680):04871 FCB 8
4961+2654 2052616E6765203F (fig-forth-auto680):04872 FCC ' Range ?' ; ' Range ?'
4962+265C 21D7 (fig-forth-auto680):04873 FDB QUIT
4963+265E 16901409 (fig-forth-auto680):04874 RW2 FDB FROMR,ZBRAN
4964+2662 0002 (fig-forth-auto680):04875 FDB RW3-*-NATWID
4965+2664 1736 (fig-forth-auto680):04876 FDB SWAP
4966+2666 18821584 (fig-forth-auto680):04877 RW3 FDB BBUF,CMOVE
4967+266A 1667 (fig-forth-auto680):04878 FDB SEMIS
4968+ (fig-forth-auto680):04879 *
4969+ (fig-forth-auto680):04880 * From BIF-6809:
4970+ (fig-forth-auto680):04881 * RW PSHS Y,U,DP
4971+ (fig-forth-auto680):04882 * LDY $C006 control table
4972+ (fig-forth-auto680):04883 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
4973+ (fig-forth-auto680):04884 * LDD 2,U
4974+ (fig-forth-auto680):04885 * RWD SUBD ,X++ sectors
4975+ (fig-forth-auto680):04886 * BHS RWD
4976+ (fig-forth-auto680):04887 * BVC RWR table end?
4977+ (fig-forth-auto680):04888 * LDD #6
4978+ (fig-forth-auto680):04889 * PSHU D
4979+ (fig-forth-auto680):04890 * JMP ERROR
4980+ (fig-forth-auto680):04891 * RWR ADDD ,--X back one
4981+ (fig-forth-auto680):04892 * PSHS X
4982+ (fig-forth-auto680):04893 * PSHU D
4983+ (fig-forth-auto680):04894 * LDD #18 sectors/track
4984+ (fig-forth-auto680):04895 * PSHU D
4985+ (fig-forth-auto680):04896 * DOCOL
4986+ (fig-forth-auto680):04897 * FDB SLAMOD
4987+ (fig-forth-auto680):04898 * FDB XMACH
4988+ (fig-forth-auto680):04899 * PULU D
4989+ (fig-forth-auto680):04900 * STB 2,Y track
4990+ (fig-forth-auto680):04901 * PULU D
4991+ (fig-forth-auto680):04902 * INCB
4992+ (fig-forth-auto680):04903 * STB 3,Y sector
4993+ (fig-forth-auto680):04904 * PULS D table entry
4994+ (fig-forth-auto680):04905 * SUBD #DROFFS+7
4995+ (fig-forth-auto680):04906 * ASRB drive #
4996+ (fig-forth-auto680):04907 * STB 1,Y
4997+ (fig-forth-auto680):04908 * LDD 4,U buffer
4998+ (fig-forth-auto680):04909 * STD 4,Y
4999+ (fig-forth-auto680):04910 * LDB #2 coco READ
5000+ (fig-forth-auto680):04911 * LDX ,U 0?
5001+ (fig-forth-auto680):04912 * BNE *+3
5002+ (fig-forth-auto680):04913 * INCB coco WRITE
5003+ (fig-forth-auto680):04914 * STB ,Y op code
5004+ (fig-forth-auto680):04915 * CLRA
5005+ (fig-forth-auto680):04916 * TFR A,DP
5006+ (fig-forth-auto680):04917 * JSR [$C004] ROM handles timeout
5007+ (fig-forth-auto680):04918 * PULS Y,U,DP if IRQ enabled
5008+ (fig-forth-auto680):04919 * LEAU 6,U
5009+ (fig-forth-auto680):04920 * LDX $C006
5010+ (fig-forth-auto680):04921 * LDB 6,X coco status
5011+ (fig-forth-auto680):04922 * BEQ RWE
5012+ (fig-forth-auto680):04923 * LDX <UP
5013+ (fig-forth-auto680):04924 * LDD #0 no disc
5014+ (fig-forth-auto680):04925 * STD UWARN,X
5015+ (fig-forth-auto680):04926 * LDD #8
5016+ (fig-forth-auto680):04927 * PSHU D
5017+ (fig-forth-auto680):04928 * JMP ERROR
5018+ (fig-forth-auto680):04929 * RWE NEXT
5019+ (fig-forth-auto680):04930 *
5020+ (fig-forth-auto680):04931 * ######>> screen 72 <<
5021+ (fig-forth-auto680):04932 * ======>> 192 <<
5022+ (fig-forth-auto680):04933 * ( --- ) compiling P
5023+ (fig-forth-auto680):04934 * ( --- adr ) interpreting
5024+ (fig-forth-auto680):04935 * { ' name } input
5025+ (fig-forth-auto680):04936 * Parse a symbol name from input and search the dictionary for it, per -FIND;
5026+ (fig-forth-auto680):04937 * compile the address as a literal if compiling,
5027+ (fig-forth-auto680):04938 * otherwise just push it.
5028+266C C1 (fig-forth-auto680):04939 FCB $C1 immediate
5029+266D A7 (fig-forth-auto680):04940 FCB $A7 ' ( tick )
5030+266E 2635 (fig-forth-auto680):04941 FDB RW-6
5031+2670 17B91FAD16A3183D (fig-forth-auto680):04942 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
5032+ 1B39172A20E2
5033+267E 1667 (fig-forth-auto680):04943 FDB SEMIS
5034+ (fig-forth-auto680):04944 *
5035+ (fig-forth-auto680):04945 * ======>> 193 <<
5036+ (fig-forth-auto680):04946 * ( --- ) { FORGET name } input
5037+ (fig-forth-auto680):04947 * Parse out name of definition to FORGET to, -DFIND it,
5038+ (fig-forth-auto680):04948 * then lop it and everything that follows out of the dictionary.
5039+ (fig-forth-auto680):04949 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
5040+2680 86 (fig-forth-auto680):04950 FCB $86
5041+2681 464F524745 (fig-forth-auto680):04951 FCC 'FORGE' ; 'FORGET'
5042+2686 D4 (fig-forth-auto680):04952 FCB $D4
5043+2687 266C (fig-forth-auto680):04953 FDB TICK-4
5044+2689 17B9194C1772193E (fig-forth-auto680):04954 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
5045+ 17721A0413A7
5046+2697 18 (fig-forth-auto680):04955 FCB $18
5047+2698 1B392670174518E4 (fig-forth-auto680):04956 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
5048+ 17721A1D13A7
5049+26A6 15 (fig-forth-auto680):04957 FCB $15
5050+26A7 1B391745183D189C (fig-forth-auto680):04958 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
5051+ 1A3513A7
5052+26B3 15 (fig-forth-auto680):04959 FCB $15
5053+26B4 1B3917451AFD18ED (fig-forth-auto680):04960 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
5054+ 178A1AE01772193E
5055+ 1772178A
5056+26C8 1667 (fig-forth-auto680):04961 FDB SEMIS
5057+ (fig-forth-auto680):04962 *
5058+ (fig-forth-auto680):04963 * ######>> screen 73 <<
5059+ (fig-forth-auto680):04964 * ======>> 194 <<
5060+ (fig-forth-auto680):04965 * ( adr --- ) C
5061+ (fig-forth-auto680):04966 * Calculate a back reference from HERE and compile it.
5062+26CA 84 (fig-forth-auto680):04967 FCB $84
5063+26CB 424143 (fig-forth-auto680):04968 FCC 'BAC' ; 'BACK'
5064+26CE CB (fig-forth-auto680):04969 FCB $CB
5065+26CF 2680 (fig-forth-auto680):04970 FDB FORGET-9
5066+ (fig-forth-auto680):04971 * BACK FDB DOCOL,HERE,SUB,COMMA
5067+26D1 17B919C718021A04 (fig-forth-auto680):04972 BACK FDB DOCOL,HERE,NATP,SUB,COMMA
5068+ 19E3
5069+26DB 1667 (fig-forth-auto680):04973 FDB SEMIS
5070+ (fig-forth-auto680):04974 *
5071+ (fig-forth-auto680):04975 * ======>> 195 <<
5072+ (fig-forth-auto680):04976 * ( --- ) runtime
5073+ (fig-forth-auto680):04977 * typical use: BEGIN code-loop test UNTIL
5074+ (fig-forth-auto680):04978 * typical use: BEGIN code-loop AGAIN
5075+ (fig-forth-auto680):04979 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5076+ (fig-forth-auto680):04980 * ( --- adr n ) compile time P,C
5077+ (fig-forth-auto680):04981 * Push HERE for BACK reference for general (non-counting) loops,
5078+ (fig-forth-auto680):04982 * with BEGIN construct flag.
5079+ (fig-forth-auto680):04983 * A better flag: $4245 (ASCII for 'BE').
5080+26DD C5 (fig-forth-auto680):04984 FCB $C5
5081+26DE 42454749 (fig-forth-auto680):04985 FCC 'BEGI' ; 'BEGIN'
5082+26E2 CE (fig-forth-auto680):04986 FCB $CE
5083+26E3 26CA (fig-forth-auto680):04987 FDB BACK-7
5084+26E5 17B91B5319C71845 (fig-forth-auto680):04988 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
5085+26ED 1667 (fig-forth-auto680):04989 FDB SEMIS
5086+ (fig-forth-auto680):04990 *
5087+ (fig-forth-auto680):04991 * ======>> 196 <<
5088+ (fig-forth-auto680):04992 * ( --- ) runtime
5089+ (fig-forth-auto680):04993 * typical use: test IF code-true ELSE code-false ENDIF
5090+ (fig-forth-auto680):04994 * ENDIF is just a sort of intersection piece,
5091+ (fig-forth-auto680):04995 * marking where execution resumes after both branches.
5092+ (fig-forth-auto680):04996 * ( adr n --- ) compile time
5093+ (fig-forth-auto680):04997 * Check the mark and resolve the IF.
5094+ (fig-forth-auto680):04998 * A better flag: $4846 (ASCII for 'IF').
5095+26EF C5 (fig-forth-auto680):04999 FCB $C5
5096+26F0 454E4449 (fig-forth-auto680):05000 FCC 'ENDI' ; 'ENDIF'
5097+26F4 C6 (fig-forth-auto680):05001 FCB $C6
5098+26F5 26DD (fig-forth-auto680):05002 FDB BEGIN-8
5099+26F7 17B91B53184D1B80 (fig-forth-auto680):05003 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
5100+ 19C7
5101+2701 171C18021A041736 (fig-forth-auto680):05004 FDB OVER,NATP,SUB,SWAP,STORE
5102+ 178A
5103+270B 1667 (fig-forth-auto680):05005 FDB SEMIS
5104+ (fig-forth-auto680):05006 *
5105+ (fig-forth-auto680):05007 * ======>> 197 <<
5106+ (fig-forth-auto680):05008 * ( --- ) runtime
5107+ (fig-forth-auto680):05009 * typical use: test IF code-true ELSE code-false ENDIF
5108+ (fig-forth-auto680):05010 * ( adr n --- )
5109+ (fig-forth-auto680):05011 * Alias for ENDIF .
5110+270D C4 (fig-forth-auto680):05012 FCB $C4
5111+270E 544845 (fig-forth-auto680):05013 FCC 'THE' ; 'THEN'
5112+2711 CE (fig-forth-auto680):05014 FCB $CE
5113+2712 26EF (fig-forth-auto680):05015 FDB ENDIF-8
5114+2714 17B926F7 (fig-forth-auto680):05016 THEN FDB DOCOL,ENDIF
5115+2718 1667 (fig-forth-auto680):05017 FDB SEMIS
5116+ (fig-forth-auto680):05018 *
5117+ (fig-forth-auto680):05019 * ======>> 198 <<
5118+ (fig-forth-auto680):05020 * ( limit index --- ) runtime
5119+ (fig-forth-auto680):05021 * typical use: DO code-loop LOOP
5120+ (fig-forth-auto680):05022 * typical use: DO code-loop increment +LOOP
5121+ (fig-forth-auto680):05023 * Counted loop, index is initial value of index.
5122+ (fig-forth-auto680):05024 * Will loop until index equals (positive going)
5123+ (fig-forth-auto680):05025 * or passes (negative going) limit.
5124+ (fig-forth-auto680):05026 * ( --- adr n ) compile time P,C
5125+ (fig-forth-auto680):05027 * Compile (DO), push HERE for BACK reference,
5126+ (fig-forth-auto680):05028 * and push DO control construct flag.
5127+ (fig-forth-auto680):05029 * A better flag: $444F (ASCII for 'DO').
5128+271A C2 (fig-forth-auto680):05030 FCB $C2
5129+271B 44 (fig-forth-auto680):05031 FCC 'D' ; 'DO'
5130+271C CF (fig-forth-auto680):05032 FCB $CF
5131+271D 270D (fig-forth-auto680):05033 FDB THEN-7
5132+271F 17B91BC7145319C7 (fig-forth-auto680):05034 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
5133+ 1855
5134+2729 1667 (fig-forth-auto680):05035 FDB SEMIS
5135+ (fig-forth-auto680):05036 *
5136+ (fig-forth-auto680):05037 * ======>> 199 <<
5137+ (fig-forth-auto680):05038 * ( --- ) runtime
5138+ (fig-forth-auto680):05039 * typical use: DO code-loop LOOP
5139+ (fig-forth-auto680):05040 * Increments the index by one and branches back to beginning of loop.
5140+ (fig-forth-auto680):05041 * Will loop until index equals limit.
5141+ (fig-forth-auto680):05042 * ( adr n --- ) compile time P,C
5142+ (fig-forth-auto680):05043 * Check the mark and compile (LOOP), fill in BACK reference.
5143+ (fig-forth-auto680):05044 * A better flag: $444F (ASCII for 'DO').
5144+272B C4 (fig-forth-auto680):05045 FCB $C4
5145+272C 4C4F4F (fig-forth-auto680):05046 FCC 'LOO' ; 'LOOP'
5146+272F D0 (fig-forth-auto680):05047 FCB $D0
5147+2730 271A (fig-forth-auto680):05048 FDB DO-5
5148+2732 17B918551B801BC7 (fig-forth-auto680):05049 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
5149+ 141D26D1
5150+273E 1667 (fig-forth-auto680):05050 FDB SEMIS
5151+ (fig-forth-auto680):05051 *
5152+ (fig-forth-auto680):05052 * ======>> 200 <<
5153+ (fig-forth-auto680):05053 * ( n --- ) runtime
5154+ (fig-forth-auto680):05054 * typical use: DO code-loop increment +LOOP
5155+ (fig-forth-auto680):05055 * Increments the index by n and branches back to beginning of loop.
5156+ (fig-forth-auto680):05056 * Will loop until index equals (positive going)
5157+ (fig-forth-auto680):05057 * or passes (negative going) limit.
5158+ (fig-forth-auto680):05058 * ( adr n --- ) compile time P,C
5159+ (fig-forth-auto680):05059 * Check the mark and compile (+LOOP), fill in BACK reference.
5160+ (fig-forth-auto680):05060 * A better flag: $444F (ASCII for 'DO').
5161+2740 C5 (fig-forth-auto680):05061 FCB $C5
5162+2741 2B4C4F4F (fig-forth-auto680):05062 FCC '+LOO' ; '+LOOP'
5163+2745 D0 (fig-forth-auto680):05063 FCB $D0
5164+2746 272B (fig-forth-auto680):05064 FDB LOOP-7
5165+2748 17B918551B801BC7 (fig-forth-auto680):05065 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
5166+ 143C26D1
5167+2754 1667 (fig-forth-auto680):05066 FDB SEMIS
5168+ (fig-forth-auto680):05067 *
5169+ (fig-forth-auto680):05068 * ======>> 201 <<
5170+ (fig-forth-auto680):05069 * ( n --- ) runtime
5171+ (fig-forth-auto680):05070 * typical use: BEGIN code-loop test UNTIL
5172+ (fig-forth-auto680):05071 * Will loop until UNTIL tests true.
5173+ (fig-forth-auto680):05072 * ( adr n --- ) compile time P,C
5174+ (fig-forth-auto680):05073 * Check the mark and compile (0BRANCH), fill in BACK reference.
5175+ (fig-forth-auto680):05074 * A better flag: $4245 (ASCII for 'BE').
5176+2756 C5 (fig-forth-auto680):05075 FCB $C5
5177+2757 554E5449 (fig-forth-auto680):05076 FCC 'UNTI' ; 'UNTIL' : ( same as END )
5178+275B CC (fig-forth-auto680):05077 FCB $CC
5179+275C 2740 (fig-forth-auto680):05078 FDB PLOOP-8
5180+275E 17B918451B801BC7 (fig-forth-auto680):05079 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
5181+ 140926D1
5182+276A 1667 (fig-forth-auto680):05080 FDB SEMIS
5183+ (fig-forth-auto680):05081 *
5184+ (fig-forth-auto680):05082 * ######>> screen 74 <<
5185+ (fig-forth-auto680):05083 * ======>> 202 <<
5186+ (fig-forth-auto680):05084 * ( n --- ) runtime
5187+ (fig-forth-auto680):05085 * typical use: BEGIN code-loop test END
5188+ (fig-forth-auto680):05086 * ( adr n --- )
5189+ (fig-forth-auto680):05087 * Alias for UNTIL .
5190+276C C3 (fig-forth-auto680):05088 FCB $C3
5191+276D 454E (fig-forth-auto680):05089 FCC 'EN' ; 'END'
5192+276F C4 (fig-forth-auto680):05090 FCB $C4
5193+2770 2756 (fig-forth-auto680):05091 FDB UNTIL-8
5194+2772 17B9275E (fig-forth-auto680):05092 END FDB DOCOL,UNTIL
5195+2776 1667 (fig-forth-auto680):05093 FDB SEMIS
5196+ (fig-forth-auto680):05094 *
5197+ (fig-forth-auto680):05095 * ======>> 203 <<
5198+ (fig-forth-auto680):05096 * ( --- ) runtime
5199+ (fig-forth-auto680):05097 * typical use: BEGIN code-loop AGAIN
5200+ (fig-forth-auto680):05098 * Will loop forever
5201+ (fig-forth-auto680):05099 * (or until something uses R> DROP to force the current definition to die,
5202+ (fig-forth-auto680):05100 * or perhaps ABORT or ERROR or some such other drastic means stops things).
5203+ (fig-forth-auto680):05101 * ( adr n --- ) compile time P,C
5204+ (fig-forth-auto680):05102 * Check the mark and compile (0BRANCH), fill in BACK reference.
5205+ (fig-forth-auto680):05103 * A better flag: $4245 (ASCII for 'BE').
5206+2778 C5 (fig-forth-auto680):05104 FCB $C5
5207+2779 41474149 (fig-forth-auto680):05105 FCC 'AGAI' ; 'AGAIN'
5208+277D CE (fig-forth-auto680):05106 FCB $CE
5209+277E 276C (fig-forth-auto680):05107 FDB END-6
5210+2780 17B918451B801BC7 (fig-forth-auto680):05108 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
5211+ 13FA26D1
5212+278C 1667 (fig-forth-auto680):05109 FDB SEMIS
5213+ (fig-forth-auto680):05110 *
5214+ (fig-forth-auto680):05111 * ======>> 204 <<
5215+ (fig-forth-auto680):05112 * ( --- ) runtime
5216+ (fig-forth-auto680):05113 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5217+ (fig-forth-auto680):05114 * Will loop until WHILE tests false, skipping code-true on end.
5218+ (fig-forth-auto680):05115 * REPEAT marks where execution resumes after the WHILE find a false flag.
5219+ (fig-forth-auto680):05116 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
5220+ (fig-forth-auto680):05117 * Check the marks for WHILE and BEGIN,
5221+ (fig-forth-auto680):05118 * compile BRANCH and BACK fill adr1 reference,
5222+ (fig-forth-auto680):05119 * FILL-IN 0BRANCH reference at adr2.
5223+ (fig-forth-auto680):05120 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5224+278E C6 (fig-forth-auto680):05121 FCB $C6
5225+278F 5245504541 (fig-forth-auto680):05122 FCC 'REPEA' ; 'REPEAT'
5226+2794 D4 (fig-forth-auto680):05123 FCB $D4
5227+2795 2778 (fig-forth-auto680):05124 FDB AGAIN-8
5228+2797 17B9168116812780 (fig-forth-auto680):05125 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
5229+ 16901690
5230+27A3 184D1A0426F7 (fig-forth-auto680):05126 FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
5231+27A9 1667 (fig-forth-auto680):05127 FDB SEMIS
5232+ (fig-forth-auto680):05128 *
5233+ (fig-forth-auto680):05129 * ======>> 205 <<
5234+ (fig-forth-auto680):05130 * ( n --- ) runtime
5235+ (fig-forth-auto680):05131 * typical use: test IF code-true ELSE code-false ENDIF
5236+ (fig-forth-auto680):05132 * Will pass execution to the true part on a true flag
5237+ (fig-forth-auto680):05133 * and to the false part on a false flag.
5238+ (fig-forth-auto680):05134 * ( --- adr n ) compile time P,C
5239+ (fig-forth-auto680):05135 * Compile a 0BRANCH and dummy offset
5240+ (fig-forth-auto680):05136 * and push IF reference to fill in and
5241+ (fig-forth-auto680):05137 * IF control construct flag.
5242+ (fig-forth-auto680):05138 * A better flag: $4946 (ASCII for 'IF').
5243+27AB C2 (fig-forth-auto680):05139 FCB $C2
5244+27AC 49 (fig-forth-auto680):05140 FCC 'I' ; 'IF'
5245+27AD C6 (fig-forth-auto680):05141 FCB $C6
5246+27AE 278E (fig-forth-auto680):05142 FDB REPEAT-9
5247+27B0 17B91BC7140919C7 (fig-forth-auto680):05143 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
5248+ 183D19E3184D
5249+27BE 1667 (fig-forth-auto680):05144 FDB SEMIS
5250+ (fig-forth-auto680):05145 *
5251+ (fig-forth-auto680):05146 * ======>> 206 <<
5252+ (fig-forth-auto680):05147 * ( --- ) runtime
5253+ (fig-forth-auto680):05148 * typical use: test IF code-true ELSE code-false ENDIF
5254+ (fig-forth-auto680):05149 * ELSE is just a sort of intersection piece,
5255+ (fig-forth-auto680):05150 * marking where execution resumes on a false branch.
5256+ (fig-forth-auto680):05151 * ( adr1 n --- adr2 n ) compile time P,C
5257+ (fig-forth-auto680):05152 * Check the marks,
5258+ (fig-forth-auto680):05153 * compile BRANCH with dummy offset,
5259+ (fig-forth-auto680):05154 * resolve IF reference,
5260+ (fig-forth-auto680):05155 * and leave reference to BRANCH for ELSE.
5261+ (fig-forth-auto680):05156 * A better flag: $4946 (ASCII for 'IF').
5262+27C0 C4 (fig-forth-auto680):05157 FCB $C4
5263+27C1 454C53 (fig-forth-auto680):05158 FCC 'ELS' ; 'ELSE'
5264+27C4 C5 (fig-forth-auto680):05159 FCB $C5
5265+27C5 27AB (fig-forth-auto680):05160 FDB IF-5
5266+27C7 17B9184D1B801BC7 (fig-forth-auto680):05161 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
5267+ 13FA19C7
5268+27D3 183D19E31736184D (fig-forth-auto680):05162 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
5269+ 26F7184D
5270+27DF 1667 (fig-forth-auto680):05163 FDB SEMIS
5271+ (fig-forth-auto680):05164 *
5272+ (fig-forth-auto680):05165 * ======>> 207 <<
5273+ (fig-forth-auto680):05166 * ( n --- ) runtime
5274+ (fig-forth-auto680):05167 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5275+ (fig-forth-auto680):05168 * Will loop until WHILE tests false, skipping code-true on end.
5276+ (fig-forth-auto680):05169 * ( --- adr n ) compile time P,C
5277+ (fig-forth-auto680):05170 * Compile 0BRANCH with dummy offset (using IF),
5278+ (fig-forth-auto680):05171 * push WHILE reference.
5279+ (fig-forth-auto680):05172 * BEGIN flag will sit underneath this.
5280+ (fig-forth-auto680):05173 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5281+27E1 C5 (fig-forth-auto680):05174 FCB $C5
5282+27E2 5748494C (fig-forth-auto680):05175 FCC 'WHIL' ; 'WHILE'
5283+27E6 C5 (fig-forth-auto680):05176 FCB $C5
5284+27E7 27C0 (fig-forth-auto680):05177 FDB ELSE-7
5285+27E9 17B927B019B8 (fig-forth-auto680):05178 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
5286+27EF 1667 (fig-forth-auto680):05179 FDB SEMIS
5287+ (fig-forth-auto680):05180 *
5288+ (fig-forth-auto680):05181 * ######>> screen 75 <<
5289+ (fig-forth-auto680):05182 * ======>> 208 <<
5290+ (fig-forth-auto680):05183 * ( count --- )
5291+ (fig-forth-auto680):05184 * EMIT count spaces, for non-zero, non-negative counts.
5292+27F1 86 (fig-forth-auto680):05185 FCB $86
5293+27F2 5350414345 (fig-forth-auto680):05186 FCC 'SPACE' ; 'SPACES'
5294+27F7 D3 (fig-forth-auto680):05187 FCB $D3
5295+27F8 27E1 (fig-forth-auto680):05188 FDB WHILE-8
5296+27FA 17B9183D1A771A8A (fig-forth-auto680):05189 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
5297+ 1409
5298+2804 000A (fig-forth-auto680):05190 FDB SPACE3-*-NATWID
5299+2806 183D1453 (fig-forth-auto680):05191 FDB ZERO,XDO
5300+280A 1A57141D (fig-forth-auto680):05192 SPACE2 FDB SPACE,XLOOP
5301+280E FFFA (fig-forth-auto680):05193 FDB SPACE2-*-NATWID
5302+2810 1667 (fig-forth-auto680):05194 SPACE3 FDB SEMIS
5303+ (fig-forth-auto680):05195 *
5304+ (fig-forth-auto680):05196 * ======>> 209 <<
5305+ (fig-forth-auto680):05197 * ( --- )
5306+ (fig-forth-auto680):05198 * Initialize HLD for converting a double integer.
5307+ (fig-forth-auto680):05199 * Stores the PAD address in HLD.
5308+2812 82 (fig-forth-auto680):05200 FCB $82
5309+2813 3C (fig-forth-auto680):05201 FCC '<' ; '<#'
5310+2814 A3 (fig-forth-auto680):05202 FCB $A3
5311+2815 27F1 (fig-forth-auto680):05203 FDB SPACES-9
5312+2817 17B91EAA1994178A (fig-forth-auto680):05204 BDIGS FDB DOCOL,PAD,HLD,STORE
5313+281F 1667 (fig-forth-auto680):05205 FDB SEMIS
5314+ (fig-forth-auto680):05206 *
5315+ (fig-forth-auto680):05207 * ======>> 210 <<
5316+ (fig-forth-auto680):05208 * ( d --- string length )
5317+ (fig-forth-auto680):05209 * Terminate numeric conversion,
5318+ (fig-forth-auto680):05210 * drop the number being converted,
5319+ (fig-forth-auto680):05211 * leave the address of the conversion string and the length, ready for TYPE.
5320+2821 82 (fig-forth-auto680):05212 FCB $82
5321+2822 23 (fig-forth-auto680):05213 FCC '#' ; '#>'
5322+2823 BE (fig-forth-auto680):05214 FCB $BE
5323+2824 2812 (fig-forth-auto680):05215 FDB BDIGS-5
5324+2826 17B9172A172A1994 (fig-forth-auto680):05216 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
5325+ 17721EAA171C1A04
5326+2836 1667 (fig-forth-auto680):05217 FDB SEMIS
5327+ (fig-forth-auto680):05218 *
5328+ (fig-forth-auto680):05219 * ======>> 211 <<
5329+ (fig-forth-auto680):05220 * ( n d --- d )
5330+ (fig-forth-auto680):05221 * Put sign of n (as a flag) at the head of the conversion string.
5331+ (fig-forth-auto680):05222 * Drop the sign flag.
5332+2838 84 (fig-forth-auto680):05223 FCB $84
5333+2839 534947 (fig-forth-auto680):05224 FCC 'SIG' ; 'SIGN'
5334+283C CE (fig-forth-auto680):05225 FCB $CE
5335+283D 2821 (fig-forth-auto680):05226 FDB EDIGS-5
5336+283F 17B91A4316B51409 (fig-forth-auto680):05227 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
5337+2847 0005 (fig-forth-auto680):05228 FDB SIGN2-*-NATWID
5338+2849 13A7 (fig-forth-auto680):05229 FDB LIT8
5339+284B 2D (fig-forth-auto680):05230 FCC "-"
5340+284C 1E92 (fig-forth-auto680):05231 FDB HOLD
5341+284E 1667 (fig-forth-auto680):05232 SIGN2 FDB SEMIS
5342+ (fig-forth-auto680):05233 *
5343+ (fig-forth-auto680):05234 * ======>> 212 <<
5344+ (fig-forth-auto680):05235 * ( d --- d/base )
5345+ (fig-forth-auto680):05236 * Generate next most significant digit in the conversion BASE,
5346+ (fig-forth-auto680):05237 * putting the digit at the head of the conversion string.
5347+2850 81 (fig-forth-auto680):05238 FCB $81 #
5348+2851 A3 (fig-forth-auto680):05239 FCB $A3
5349+2852 2838 (fig-forth-auto680):05240 FDB SIGN-7
5350+2854 17B9196317722368 (fig-forth-auto680):05241 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
5351+ 1A4313A7
5352+2860 09 (fig-forth-auto680):05242 FCB 9
5353+2861 171C1A1D1409 (fig-forth-auto680):05243 FDB OVER,LESS,ZBRAN
5354+2867 0005 (fig-forth-auto680):05244 FDB DIG2-*-NATWID
5355+2869 13A7 (fig-forth-auto680):05245 FDB LIT8
5356+286B 07 (fig-forth-auto680):05246 FCB 7
5357+286C 16C6 (fig-forth-auto680):05247 FDB PLUS
5358+286E 13A7 (fig-forth-auto680):05248 DIG2 FDB LIT8
5359+2870 30 (fig-forth-auto680):05249 FCC "0" ascii zero
5360+2871 16C61E92 (fig-forth-auto680):05250 FDB PLUS,HOLD
5361+2875 1667 (fig-forth-auto680):05251 FDB SEMIS
5362+ (fig-forth-auto680):05252 *
5363+ (fig-forth-auto680):05253 * ======>> 213 <<
5364+ (fig-forth-auto680):05254 * ( d --- dzero )
5365+ (fig-forth-auto680):05255 * Convert d to a numeric string using # until the result is zero.
5366+ (fig-forth-auto680):05256 * Leave the double result on the stack for #> to drop.
5367+2877 82 (fig-forth-auto680):05257 FCB $82
5368+2878 23 (fig-forth-auto680):05258 FCC '#' ; '#S'
5369+2879 D3 (fig-forth-auto680):05259 FCB $D3
5370+287A 2850 (fig-forth-auto680):05260 FDB DIG-4
5371+287C 17B9 (fig-forth-auto680):05261 DIGS FDB DOCOL
5372+287E 2854171C171C161E (fig-forth-auto680):05262 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
5373+ 16A31409
5374+288A FFF2 (fig-forth-auto680):05263 FDB DIGS2-*-NATWID
5375+288C 1667 (fig-forth-auto680):05264 FDB SEMIS
5376+ (fig-forth-auto680):05265 *
5377+ (fig-forth-auto680):05266 * ######>> screen 76 <<
5378+ (fig-forth-auto680):05267 * ======>> 214 <<
5379+ (fig-forth-auto680):05268 * ( n width --- )
5380+ (fig-forth-auto680):05269 * Print n on the output device in the current conversion base,
5381+ (fig-forth-auto680):05270 * with sign,
5382+ (fig-forth-auto680):05271 * right aligned in a field at least width wide.
5383+288E 82 (fig-forth-auto680):05272 FCB $82
5384+288F 2E (fig-forth-auto680):05273 FCC '.' ; '.R'
5385+2890 D2 (fig-forth-auto680):05274 FCB $D2
5386+2891 2877 (fig-forth-auto680):05275 FDB DIGS-5
5387+2893 17B9168122F81690 (fig-forth-auto680):05276 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
5388+ 28A5
5389+289D 1667 (fig-forth-auto680):05277 FDB SEMIS
5390+ (fig-forth-auto680):05278 *
5391+ (fig-forth-auto680):05279 * ======>> 215 <<
5392+ (fig-forth-auto680):05280 * ( d width --- )
5393+ (fig-forth-auto680):05281 * Print d on the output device in the current conversion base,
5394+ (fig-forth-auto680):05282 * with sign,
5395+ (fig-forth-auto680):05283 * right aligned in a field at least width wide.
5396+289F 83 (fig-forth-auto680):05284 FCB $83
5397+28A0 442E (fig-forth-auto680):05285 FCC 'D.' ; 'D.R'
5398+28A2 D2 (fig-forth-auto680):05286 FCB $D2
5399+28A3 288E (fig-forth-auto680):05287 FDB DOTR-5
5400+28A5 17B916811736171C (fig-forth-auto680):05288 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
5401+ 23992817287C283F
5402+28B5 28261690171C1A04 (fig-forth-auto680):05289 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
5403+ 27FA1CAF
5404+28C1 1667 (fig-forth-auto680):05290 FDB SEMIS
5405+ (fig-forth-auto680):05291 *
5406+ (fig-forth-auto680):05292 * ======>> 216 <<
5407+ (fig-forth-auto680):05293 * D. ( d --- )
5408+ (fig-forth-auto680):05294 * Print d on the output device in the current conversion base,
5409+ (fig-forth-auto680):05295 * with sign,
5410+ (fig-forth-auto680):05296 * in free format with trailing space.
5411+28C3 82 (fig-forth-auto680):05297 FCB $82
5412+28C4 44 (fig-forth-auto680):05298 FCC 'D' ; 'D.'
5413+28C5 AE (fig-forth-auto680):05299 FCB $AE
5414+28C6 289F (fig-forth-auto680):05300 FDB DDOTR-6
5415+28C8 17B9183D28A51A57 (fig-forth-auto680):05301 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
5416+28D0 1667 (fig-forth-auto680):05302 FDB SEMIS
5417+ (fig-forth-auto680):05303 *
5418+ (fig-forth-auto680):05304 * ======>> 217 <<
5419+ (fig-forth-auto680):05305 * ( n --- )
5420+ (fig-forth-auto680):05306 * Print n on the output device in the current conversion base,
5421+ (fig-forth-auto680):05307 * with sign,
5422+ (fig-forth-auto680):05308 * in free format with trailing space.
5423+28D2 81 (fig-forth-auto680):05309 FCB $81 .
5424+28D3 AE (fig-forth-auto680):05310 FCB $AE
5425+28D4 28C3 (fig-forth-auto680):05311 FDB DDOT-5
5426+28D6 17B922F828C8 (fig-forth-auto680):05312 DOT FDB DOCOL,STOD,DDOT
5427+28DC 1667 (fig-forth-auto680):05313 FDB SEMIS
5428+ (fig-forth-auto680):05314 *
5429+ (fig-forth-auto680):05315 * ======>> 218 <<
5430+ (fig-forth-auto680):05316 * ( adr --- )
5431+ (fig-forth-auto680):05317 * Print signed word at adr, per DOT.
5432+28DE 81 (fig-forth-auto680):05318 FCB $81 ?
5433+28DF BF (fig-forth-auto680):05319 FCB $BF
5434+28E0 28D2 (fig-forth-auto680):05320 FDB DOT-4
5435+28E2 17B9177228D6 (fig-forth-auto680):05321 QUEST FDB DOCOL,AT,DOT
5436+28E8 1667 (fig-forth-auto680):05322 FDB SEMIS
5437+ (fig-forth-auto680):05323 *
5438+ (fig-forth-auto680):05324 * ######>> screen 77 <<
5439+ (fig-forth-auto680):05325 * ======>> 219 <<
5440+ (fig-forth-auto680):05326 * ( n --- )
5441+ (fig-forth-auto680):05327 * Print out screen n as a field of ASCII,
5442+ (fig-forth-auto680):05328 * with line numbers in decimal.
5443+ (fig-forth-auto680):05329 * Needs a console more than 70 characters wide.
5444+28EA 84 (fig-forth-auto680):05330 FCB $84
5445+28EB 4C4953 (fig-forth-auto680):05331 FCC 'LIS' ; 'LIST'
5446+28EE D4 (fig-forth-auto680):05332 FCB $D4
5447+28EF 28DE (fig-forth-auto680):05333 FDB QUEST-4
5448+28F1 17B91C2515771745 (fig-forth-auto680):05334 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
5449+ 1923178A1D10
5450+28FF 06 (fig-forth-auto680):05335 FCB 6
5451+2900 534352202320 (fig-forth-auto680):05336 FCC "SCR # "
5452+2906 28D613A7 (fig-forth-auto680):05337 FDB DOT,LIT8
5453+290A 10 (fig-forth-auto680):05338 FCB $10
5454+290B 183D1453 (fig-forth-auto680):05339 FDB ZERO,XDO
5455+290F 157714651855 (fig-forth-auto680):05340 LIST2 FDB CR,I,THREE
5456+2915 28931A5714651923 (fig-forth-auto680):05341 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
5457+ 17722517141D
5458+2923 FFEA (fig-forth-auto680):05342 FDB LIST2-*-NATWID
5459+2925 1577 (fig-forth-auto680):05343 FDB CR
5460+2927 1667 (fig-forth-auto680):05344 FDB SEMIS
5461+ (fig-forth-auto680):05345 *
5462+ (fig-forth-auto680):05346 * ======>> 220 <<
5463+ (fig-forth-auto680):05347 * ( start end --- )
5464+ (fig-forth-auto680):05348 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
5465+ (fig-forth-auto680):05349 * from start to end.
5466+ (fig-forth-auto680):05350 * Needs a console more than 70 characters wide.
5467+2929 85 (fig-forth-auto680):05351 FCB $85
5468+292A 494E4445 (fig-forth-auto680):05352 FCC 'INDE' ; 'INDEX'
5469+292E D8 (fig-forth-auto680):05353 FCB $D8
5470+292F 28EA (fig-forth-auto680):05354 FDB LIST-7
5471+2931 17B9157719AB1736 (fig-forth-auto680):05355 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
5472+ 1453
5473+293B 157714651855 (fig-forth-auto680):05356 INDEX2 FDB CR,I,THREE
5474+2941 28931A57183D1465 (fig-forth-auto680):05357 FDB DOTR,SPACE,ZERO,I,DLINE
5475+ 2517
5476+294B 156A1409 (fig-forth-auto680):05358 FDB QTERM,ZBRAN
5477+294F 0002 (fig-forth-auto680):05359 FDB INDEX3-*-NATWID
5478+2951 1675 (fig-forth-auto680):05360 FDB LEAVE
5479+2953 141D (fig-forth-auto680):05361 INDEX3 FDB XLOOP
5480+2955 FFE4 (fig-forth-auto680):05362 FDB INDEX2-*-NATWID
5481+2957 1667 (fig-forth-auto680):05363 FDB SEMIS
5482+ (fig-forth-auto680):05364 *
5483+ (fig-forth-auto680):05365 * ======>> 221 <<
5484+ (fig-forth-auto680):05366 * ( n --- )
5485+ (fig-forth-auto680):05367 * List a printer page full of screens.
5486+ (fig-forth-auto680):05368 * Line and screen number are in current base.
5487+ (fig-forth-auto680):05369 * Needs a console more than 70 characters wide.
5488+2959 85 (fig-forth-auto680):05370 FCB $85
5489+295A 54524941 (fig-forth-auto680):05371 FCC 'TRIA' ; 'TRIAD'
5490+295E C4 (fig-forth-auto680):05372 FCB $C4
5491+295F 2929 (fig-forth-auto680):05373 FDB INDEX-8
5492+2961 17B9185523251855 (fig-forth-auto680):05374 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
5493+ 2306
5494+296B 1855171C16C61736 (fig-forth-auto680):05375 FDB THREE,OVER,PLUS,SWAP,XDO
5495+ 1453
5496+2975 15771465 (fig-forth-auto680):05376 TRIAD2 FDB CR,I
5497+2979 28F1156A1409 (fig-forth-auto680):05377 FDB LIST,QTERM,ZBRAN
5498+297F 0002 (fig-forth-auto680):05378 FDB TRIAD3-*-NATWID
5499+2981 1675 (fig-forth-auto680):05379 FDB LEAVE
5500+2983 141D (fig-forth-auto680):05380 TRIAD3 FDB XLOOP
5501+2985 FFEE (fig-forth-auto680):05381 FDB TRIAD2-*-NATWID
5502+2987 157713A7 (fig-forth-auto680):05382 FDB CR,LIT8
5503+298B 0F (fig-forth-auto680):05383 FCB $0F
5504+298C 252B1577 (fig-forth-auto680):05384 FDB MESS,CR
5505+2990 1667 (fig-forth-auto680):05385 FDB SEMIS
5506+ (fig-forth-auto680):05386 *
5507+ (fig-forth-auto680):05387 * ######>> screen 78 <<
5508+ (fig-forth-auto680):05388 * ======>> 222 <<
5509+ (fig-forth-auto680):05389 * ( --- )
5510+ (fig-forth-auto680):05390 * Alphabetically list the definitions in the current vocabulary.
5511+ (fig-forth-auto680):05391 * Expects to output to printer, not TRS80 Color Computer screen.
5512+2992 85 (fig-forth-auto680):05392 FCB $85
5513+2993 564C4953 (fig-forth-auto680):05393 FCC 'VLIS' ; 'VLIST'
5514+2997 D4 (fig-forth-auto680):05394 FCB $D4
5515+2998 2959 (fig-forth-auto680):05395 FDB TRIAD-8
5516+299A 17B913A7 (fig-forth-auto680):05396 VLIST FDB DOCOL,LIT8
5517+299E 80 (fig-forth-auto680):05397 FCB $80
5518+299F 1919178A193E1772 (fig-forth-auto680):05398 FDB OUT,STORE,CONTXT,AT,AT
5519+ 1772
5520+29A9 1919177219A21772 (fig-forth-auto680):05399 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
5521+ 13A7
5522+29B3 20 (fig-forth-auto680):05400 FCB 32
5523+29B4 1A041A351409 (fig-forth-auto680):05401 FDB SUB,GREAT,ZBRAN
5524+29BA 0008 (fig-forth-auto680):05402 FDB VLIST2-*-NATWID
5525+29BC 1577183D1919178A (fig-forth-auto680):05403 FDB CR,ZERO,OUT,STORE
5526+29C4 174520301A571A57 (fig-forth-auto680):05404 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
5527+ 1B121AE01772
5528+29D2 174516A3156A161E (fig-forth-auto680):05405 FDB DUP,ZEQU,QTERM,OR,ZBRAN
5529+ 1409
5530+29DC FFCB (fig-forth-auto680):05406 FDB VLIST1-*-NATWID
5531+29DE 172A (fig-forth-auto680):05407 FDB DROP
5532+29E0 1667 (fig-forth-auto680):05408 FDB SEMIS
5533+ (fig-forth-auto680):05409 *
5534+ (fig-forth-auto680):05410 * Need some utility stuff that isn't in the fig FORTH:
5535+ (fig-forth-auto680):05411 * ( c --- )
5536+ (fig-forth-auto680):05412 * Emit dot if c is less than blank, else emit c
5537+29E2 85 (fig-forth-auto680):05413 FCB $85
5538+29E3 42454D49 (fig-forth-auto680):05414 FCC 'BEMI' ; 'BEMIT'
5539+29E7 D4 (fig-forth-auto680):05415 FCB $D4 ; 'T'
5540+29E8 2992 (fig-forth-auto680):05416 FDB VLIST-8
5541+29EA 17B9 (fig-forth-auto680):05417 BEMIT FDB DOCOL
5542+29EC 1745185E1A1D1409 (fig-forth-auto680):05418 FDB DUP,BL,LESS,ZBRAN
5543+29F4 0005 (fig-forth-auto680):05419 FDB BEMITO-*-NATWID
5544+29F6 172A13A7 (fig-forth-auto680):05420 FDB DROP,LIT8
5545+29FA 2E (fig-forth-auto680):05421 FCB $2e ; '.'
5546+29FB 1542 (fig-forth-auto680):05422 BEMITO FDB EMIT
5547+29FD 1667 (fig-forth-auto680):05423 FDB SEMIS
5548+ (fig-forth-auto680):05424 *
5549+ (fig-forth-auto680):05425 * ( n width --- )
5550+ (fig-forth-auto680):05426 * Output n in hexadecimal field width.
5551+29FF 83 (fig-forth-auto680):05427 FCB $83
5552+2A00 582E (fig-forth-auto680):05428 FCC 'X.' ; 'X.R'
5553+2A02 D2 (fig-forth-auto680):05429 FCB $D2 ; 'R'
5554+2A03 29E2 (fig-forth-auto680):05430 FDB BEMIT-8
5555+2A05 17B9 (fig-forth-auto680):05431 XDOTR FDB DOCOL
5556+2A07 1963177216811C10 (fig-forth-auto680):05432 FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
5557+ 289316901963178A
5558+2A17 1667 (fig-forth-auto680):05433 FDB SEMIS
5559+ (fig-forth-auto680):05434 *
5560+ (fig-forth-auto680):05435 * ( adr --- )
5561+ (fig-forth-auto680):05436 * Dump a line of 4 bytes in memory, in hex and as characters.
5562+2A19 85 (fig-forth-auto680):05437 FCB $85
5563+2A1A 424C494E (fig-forth-auto680):05438 FCC 'BLIN' ; 'BLINE'
5564+2A1E C5 (fig-forth-auto680):05439 FCB $C5 ; 'E'
5565+2A1F 29FF (fig-forth-auto680):05440 FDB XDOTR-6
5566+2A21 17B9 (fig-forth-auto680):05441 BLINE FDB DOCOL
5567+2A23 174513A7 (fig-forth-auto680):05442 FDB DUP,LIT8
5568+2A27 04 (fig-forth-auto680):05443 FCB 4
5569+2A28 16C6171C1453 (fig-forth-auto680):05444 FDB PLUS,OVER,XDO
5570+2A2E 1465177E18552A05 (fig-forth-auto680):05445 BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
5571+ 141D
5572+2A38 FFF4 (fig-forth-auto680):05446 FDB BLINEX-*-NATWID
5573+2A3A 1A571A57 (fig-forth-auto680):05447 FDB SPACE,SPACE
5574+2A3E 174513A7 (fig-forth-auto680):05448 FDB DUP,LIT8
5575+2A42 04 (fig-forth-auto680):05449 FCB 4
5576+2A43 17361453 (fig-forth-auto680):05450 FDB SWAP,XDO
5577+2A47 1465177E29EA141D (fig-forth-auto680):05451 BLINEC FDB I,CAT,BEMIT,XLOOP
5578+2A4F FFF6 (fig-forth-auto680):05452 FDB BLINEC-*-NATWID
5579+2A51 1667 (fig-forth-auto680):05453 FDB SEMIS
5580+ (fig-forth-auto680):05454 *
5581+ (fig-forth-auto680):05455 * ( start end --- )
5582+ (fig-forth-auto680):05456 * Dump 4 byte lines from start to end.
5583+2A53 85 (fig-forth-auto680):05457 FCB $85
5584+2A54 4244554D (fig-forth-auto680):05458 FCC 'BDUM' ; 'BDUMP'
5585+2A58 D0 (fig-forth-auto680):05459 FCB $D0 ; '5'
5586+2A59 2A19 (fig-forth-auto680):05460 FDB BLINE-8
5587+2A5B 17B9 (fig-forth-auto680):05461 BDUMP FDB DOCOL
5588+2A5D 1453 (fig-forth-auto680):05462 FDB XDO
5589+2A5F 146513A7 (fig-forth-auto680):05463 BDUMPL FDB I,LIT8
5590+2A63 04 (fig-forth-auto680):05464 FCB 4
5591+2A64 2A0513A7 (fig-forth-auto680):05465 FDB XDOTR,LIT8
5592+2A68 3A (fig-forth-auto680):05466 FCB $3A
5593+2A69 15421A57 (fig-forth-auto680):05467 FDB EMIT,SPACE
5594+2A6D 14652A21157713A7 (fig-forth-auto680):05468 FDB I,BLINE,CR,LIT8
5595+2A75 04 (fig-forth-auto680):05469 FCB 4
5596+2A76 143C (fig-forth-auto680):05470 FDB XPLOOP
5597+2A78 FFE5 (fig-forth-auto680):05471 FDB BDUMPL-*-NATWID
5598+2A7A 1667 (fig-forth-auto680):05472 FDB SEMIS
5599+ (fig-forth-auto680):05473 *
5600+ (fig-forth-auto680):05474 * ======>> XX <<
5601+ (fig-forth-auto680):05475 * ( --- )
5602+ (fig-forth-auto680):05476 * Mostly for place holding (fig Forth).
5603+2A7C 84 (fig-forth-auto680):05477 FCB $84
5604+2A7D 4E4F4F (fig-forth-auto680):05478 FCC 'NOO' ; 'NOOP'
5605+2A80 D0 (fig-forth-auto680):05479 FCB $D0
5606+2A81 2A53 (fig-forth-auto680):05480 FDB BDUMP-8
5607+2A83 1228 (fig-forth-auto680):05481 NOOP FDB NEXT a useful no-op
5608+2A85 0000000000000000 (fig-forth-auto680):05482 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
5609+ 0000000000000000
5610+ (fig-forth-auto680):05483
5611+ (fig-forth-auto680):05484 PAGE
5612+ (fig-forth-auto680):05485 * These things, up through the lable 'REND', are overwritten
5613+ (fig-forth-auto680):05486 * at time of cold load and should have the same contents
5614+ (fig-forth-auto680):05487 * as shown here:
5615+ (fig-forth-auto680):05488 *
5616+ (fig-forth-auto680):05489 * This can be moved whereever the bottom of the
5617+ (fig-forth-auto680):05490 * user's dictionary is going to be put.
5618+ (fig-forth-auto680):05491 *
5619+2A95 C5 (fig-forth-auto680):05492 FCB $C5 immediate
5620+2A96 464F5254 (fig-forth-auto680):05493 FCC 'FORT' ; 'FORTH'
5621+2A9A C8 (fig-forth-auto680):05494 FCB $C8
5622+2A9B 2A7C (fig-forth-auto680):05495 FDB NOOP-7
5623+2A9D 1C8621A181A02AC5 (fig-forth-auto680):05496 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
5624+2AA5 0000 (fig-forth-auto680):05497 FDB 0
5625+ (fig-forth-auto680):05498 *
5626+2AA7 28432920466F7274 (fig-forth-auto680):05499 FCC "(C) Forth Interest Group, 1979"
5627+ 6820496E74657265
5628+ 73742047726F7570
5629+ 2C2031393739
5630+ (fig-forth-auto680):05500
5631+2AC5 84 (fig-forth-auto680):05501 FCB $84
5632+2AC6 544153 (fig-forth-auto680):05502 FCC 'TAS' ; 'TASK'
5633+2AC9 CB (fig-forth-auto680):05503 FCB $CB
5634+2ACA 2A95 (fig-forth-auto680):05504 FDB FORTH-8
5635+2ACC 17B91667 (fig-forth-auto680):05505 TASK FDB DOCOL,SEMIS
5636+ (fig-forth-auto680):05506 *
5637+ 2AD0 (fig-forth-auto680):05507 REND EQU * ( first empty location in dictionary )
5638+ (fig-forth-auto680):05508
5639+ (fig-forth-auto680):05509
5640+ (fig-forth-auto680):05510
5641+ (fig-forth-auto680):05511
5642+ (fig-forth-auto680):05512
5643+ (fig-forth-auto680):05513
5644+ (fig-forth-auto680):05514
5645+ (fig-forth-auto680):05515 PAGE
5646+ (fig-forth-auto680):05516 OPT L
5647+ (fig-forth-auto680):05517 END
旧リポジトリブラウザで表示