fig6800to6809dumb.asm

   1         OPT PRT
   2
   3 * fig-FORTH FOR 6809, converted by unintelligent conversion from 6800 source.
   4
   5 * To do:
   6 * 4 IO routines -- OK?
   7 * adjust ram locations -- OK?
   8 * then add trace routines -- OK?
   9 * then try in emulator
  10
  11 * ASSEMBLY SOURCE LISTING
  12
  13 * RELEASE 1
  14 * MAY 1979
  15 * WITH COMPILER SECURITY
  16 * AND VARIABLE LENGTH NAMES
  17
  18 * This public domain publication is provided
  19 * through the courtesy of:
  20 * FORTH
  21 * INTEREST
  22 * GROUP
  23 * fig
  24
  25 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
  26 * Further distribution must include this notice.
  27         PAGE
  28         NAM     Copyright:FORTH Interest Group
  29         OPT     NOG,PAG
  30 * filename FTH7.21
  31 * === FORTH-6800 06-06-79 21:OO
  32
  33
  34 * This listing is in the PUBLIC DOMAIN and
  35 * may be freely copied or published with the
  36 * restriction that a credit line is printed
  37 * with the material, crediting the
  38 * authors and the FORTH INTEREST GROUP.
  39
  40 * === by Dave Lion,
  41 * ===  with help from
  42 * === Bob Smith,
  43 * === LaFarr Stuart,
  44 * === The Forth Interest Group
  45 * === PO Box 1105
  46 * === San Carlos, CA 94070
  47 * ===  and
  48 * === Unbounded Computing
  49 * === 1134-K Aster Ave.
  50 * === Sunnyvale, CA 94086
  51 *
  52 *  This version was developed on an AMI EVK 300 PROTO
  53 *  system using an ACIA for the I/O. All terminal 1/0
  54 *  is done in three subroutines:
  55 *   PEMIT  ( word # 182 )
  56 *   PKEY   (        183 )
  57 *   PQTERM (        184 )
  58 * Note: PCR, also. (PRTCR)
  59 *
  60 *  The FORTH words for disc related I/O follow the model
  61 *  of the FORTH Interest Group, but have not been
  62 *  tested using a real disc.
  63 *
  64 *  Addresses in this implementation reflect the fact that,
  65 *  on the development system, it was convenient to
  66 *  write-protect memory at hex 1000, and leave the first
  67 *  4K bytes write-enabled. As a consequence, code from
  68 *  location $1000 to lable ZZZZ could be put in ROM.
  69 *  Minor deviations from the model were made in the
  70 *  initialization and words ?STACK and FORGET
  71 *  in order to do this.
  72 *
  73
  74
  75 *
  76 NBLK    EQU     4       # of disc buffer blocks for virtual memory
  77 * MEMEND        EQU     132*NBLK+$3000 end of ram
  78 MEMEND  EQU     132*NBLK+$5000+132 end of ram with some breathing room (32K Coco)
  79 *  each block is 132 bytes in size,
  80 *  holding 128 characters
  81 *
  82 * MEMTOP        EQU     $3FFF   absolute end of all ram
  83 MEMTOP  EQU     $7FFF   putative absolute end of all ram (32K Coco)
  84 * No ACIA in Coco (how sad).
  85 * ACIAC EQU     $FBCE   the ACIA control address and
  86 * ACIAD EQU     ACIAC+1 data address for PROTO
  87         PAGE
  88 *  MEMORY MAP for this 16K system (32K Coco):
  89 *  ( positioned so that systems with 4k byte write-
  90 *   protected segments can write protect FORTH )
  91 *
  92 * Read below and calculate it yourself:
  93 * addr.         contents                pointer init by
  94 * ****  ******************************* ******* ******
  95 * 3FFF                                          HI
  96 *       substitute for disc mass memory
  97 * 3210                                          LO,MEMEND
  98 * 320F
  99 *       4 buffer sectors of VIRTUAL MEMORY
 100 * 3000                                          FIRST
 101 * >>>>>> memory from here up must be RAM <<<<<<
 102 *
 103 * 27FF
 104 *       6k of romable "FORTH"           <== IP  ABORT
 105 *                                       <== W
 106 *       the VIRTUAL FORTH MACHINE
 107 *
 108 * 1004 (3004) <<< WARM START ENTRY >>>
 109 * 1000 (3000) <<< COLD START ENTRY >>>
 110 *
 111 * >>>>>> memory from here down must be RAM <<<<<<
 112 *  FFE  RETURN STACK base               <== RP  RINIT
 113 *
 114 *  FB4
 115 *       INPUT LINE BUFFER
 116 *       holds up to 132 characters
 117 *       and is scanned upward by IN
 118 *       starting at TIB
 119 *  F30                                  <== IN  TIB
 120 *  F2F  DATA STACK                      <== SP  SP0,SINIT
 121 *    |  grows downward from F2F
 122 *    v
 123 *  - -
 124 *    |
 125 *    I  DICTIONARY grows upward
 126 *
 127 *  183  end of ram-dictionary.          <== DP  DPINIT
 128 *       "TASK"
 129 *
 130 *  150  "FORTH" ( a word )              <=, <== CONTEXT
 131 *                                       `==== CURRENT
 132 *  148  start of ram-dictionary.
 133 *
 134 *  100  user #l table of variables      <= UP   DPINIT
 135 *   F0  registers & pointers for the virtual machine
 136 *       scratch area used by various words
 137 *   E0  lowest address used by FORTH
 138 *
 139 * 0000
 140         PAGE
 141 ***
 142 *
 143 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
 144 *
 145 * IP points to the current instruction ( pre-increment mode )
 146 * RP points to second free byte (first free word) in return stack
 147 * SP (hardware SP) points to first free byte in data stack
 148 *
 149 *       when A AND B hold one 16 bit FORTH data word,
 150 *       A contains the high byte, B, the low byte.
 151 ***
 152
 153
 154
 155
 156 *       ORG     $E0     variables
 157         ORG     $1300   variables
 158 PGBASE  EQU     *
 159 PGBDP   EQU     PGBASE/$100
 160         SETDP   PGBDP
 161
 162
 163 N       RMB     10      used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
 164 *                               SP@,SWAP,DOES>,COLD
 165
 166
 167 *       These locations are used by the TRACE routine :
 168
 169 TRLIM   RMB     1       the count for tracing without user intervention
 170 TRACEM  RMB     1       non-zero = trace mode
 171 BRKPT   RMB     2       the breakpoint address at which
 172 *                       the program will go into trace mode
 173 VECT    RMB     2       vector to machine code
 174 *       (only needed if the TRACE routine is resident)
 175
 176
 177 *       Registers used by the FORTH virtual machine:
 178 *       Starting at $OOFO:
 179
 180
 181 W       RMB     2       the instruction register points to 6800 code
 182 IP      RMB     2       the instruction pointer points to pointer to 6800 code
 183 RP      RMB     2       the return stack pointer
 184 UP      RMB     2       the pointer to base of current user's 'USER' table
 185 *               ( altered during multi-tasking )
 186 *
 187 * For the tracer:
 188         RMB 4
 189 TRASP   RMB 2
 190 TRAVEC  RMB 2
 191 TRAA    RMB 1
 192 TRAB    RMB 1
 193 FLAGON  RMB 1
 194 *
 195         PAGE
 196 *       This system is shown with one user, but additional users
 197 *       may be added by allocating additional user tables:
 198 *       UORIG2 RMB 64 data table for user #2
 199 *
 200 *
 201 *       Some of this stuff gets initialized during
 202 *       COLD start and WARM start:
 203 *       [ names correspond to FORTH words of similar (no X) name ]
 204 *
 205 *       ORG     $100
 206         ORG     $1400
 207 UORIG   RMB     6       3 reserved variables
 208 XSPZER  RMB     2       initial top of data stack for this user
 209 XRZERO  RMB     2       initial top of return stack
 210 XTIB    RMB     2       start of terminal input buffer
 211 XWIDTH  RMB     2       name field width
 212 XWARN   RMB     2       warning message mode (0 = no disc)
 213 XFENCE  RMB     2       fence for FORGET
 214 XDP     RMB     2       dictionary pointer
 215 XVOCL   RMB     2       vocabulary linking
 216 XBLK    RMB     2       disc block being accessed
 217 XIN     RMB     2       scan pointer into the block
 218 XOUT    RMB     2       cursor position
 219 XSCR    RMB     2       disc screen being accessed ( O=terminal )
 220 XOFSET  RMB     2       disc sector offset for multi-disc
 221 XCONT   RMB     2       last word in primary search vocabulary
 222 XCURR   RMB     2       last word in extensible vocabulary
 223 XSTATE  RMB     2       flag for 'interpret' or 'compile' modes
 224 XBASE   RMB     2       number base for I/O numeric conversion
 225 XDPL    RMB     2       decimal point place
 226 XFLD    RMB     2
 227 XCSP    RMB     2       current stack position, for compile checks
 228 XRNUM   RMB     2
 229 XHLD    RMB     2
 230 XDELAY  RMB     2       carriage return delay count
 231 XCOLUM  RMB     2       carriage width
 232 IOSTAT  RMB     2       last acia status from write/read
 233         RMB     2       ( 4 spares! )
 234         RMB     2
 235         RMB     2
 236         RMB     2
 237
 238
 239
 240
 241 *
 242 *
 243 *   end of user table, start of common system variables
 244 *
 245 *
 246 *
 247 XUSE    RMB     2
 248 XPREV   RMB     2
 249         RMB     4       ( spares )
 250
 251         PAGE
 252 *  These things, up through the lable 'REND', are overwritten
 253 *  at time of cold load and should have the same contents
 254 *  as shown here:
 255 *
 256         FCB     $C5     immediate
 257         FCC     'FORT'  ; 'FORTH'
 258         FCB     $C8
 259         FDB     NOOP-7
 260 FORTH   FDB     DODOES,DOVOC,$81A0,TASK-7
 261         FDB     0
 262 *
 263         FCC     "(C) Forth Interest Group, 1979"
 264
 265         FCB     $84
 266         FCC     'TAS'   ; 'TASK'
 267         FCB     $CB
 268         FDB     FORTH-8
 269 TASK    FDB     DOCOL,SEMIS
 270 *
 271 REND    EQU     *       ( first empty location in dictionary )
 272
 273         PAGE
 274 * Check the addresses yourself:
 275 *    The FORTH program ( address $1000 to $27FF ) is written
 276 *    so that it can be in a ROM, or write-protected if desired
 277         ORG     $3000
 278
 279 * ######>> screen 3 <<
 280 *
 281 ***************************
 282 **  C O L D   E N T R Y  **
 283 ***************************
 284 ORIG    NOP
 285         JMP     CENT
 286 ***************************
 287 **  W A R M   E N T R Y  **
 288 ***************************
 289         NOP
 290         JMP     WENT    warm-start code, keeps current dictionary intact
 291
 292 *
 293 ******* startup parmeters **************************
 294 *
 295 RPTIB   EQU     $200            Give us more room to breath.
 296 SBUMPR  EQU     $10             Bumper area for stacks.
 297 *
 298         FDB     $6800,6809      cpu & revision
 299         FDB     0       topmost word in FORTH vocabulary
 300 BACKSP  FDB     $7F     backspace character for editing
 301 UPINIT  FDB     UORIG   initial user area
 302 * SINIT FDB     ORIG-$D0        initial top of data stack
 303 SINIT   FDB     ORIG-RPTIB-SBUMPR*2
 304 * RINIT FDB     ORIG-2  initial top of return stack
 305 RINIT   FDB     ORIG-SBUMPR
 306 *       FDB     ORIG-$D0        terminal input buffer
 307         FDB     ORIG-RPTIB-SBUMPR
 308         FDB     31      initial name field width
 309         FDB     0       initial warning mode (0 = no disc)
 310 FENCIN  FDB     REND    initial fence
 311 DPINIT  FDB     REND    cold start value for DP
 312 VOCINT  FDB     FORTH+8
 313 COLINT  FDB     132     initial terminal carriage width
 314 DELINT  FDB     4       initial carriage return delay
 315 ****************************************************
 316 *
 317         PAGE
 318 *
 319 * ######>> screen 13 <<
 320 * Calculate the cycles yourself:
 321 PULABX  PULS A          24 cycles until 'NEXT'
 322         PULS B
 323 STABX   STA     0,X     16 cycles until 'NEXT'
 324         STB     1,X
 325         BRA     NEXT
 326 GETX    LDA     0,X     18 cycles until 'NEXT'
 327         LDB     1,X
 328 PUSHBA  PSHS B          8 cycles until 'NEXT'
 329         PSHS A
 330
 331
 332
 333 *
 334 * "NEXT" takes 38 cycles if TRACE is removed,
 335 *
 336 * and 95 cycles if NOT tracing. (Way bogus numbers by now.)
 337 *
 338 * = = = = = = =   t h e   v i r t u a l   m a c h i n e   = = = = =
 339 *                                                                 =
 340 NEXT    LDX     IP
 341         LEAX 1,X                pre-increment mode
 342         LEAX 1,X
 343         STX     IP
 344 NEXT2   LDX     0,X     get W which points to CFA of word to be done
 345 NEXT3   STX     W
 346         LDX     0,X     get VECT which points to executable code
 347 *                                                                 =
 348 * The next instruction could be patched to JMP TRACE              =
 349 * if a TRACE routine is available:                                =
 350 *                                                                 =
 351 * Or add the TRACE routine in-line, since we are assembling it.
 352         TST TRACEM
 353         BEQ NEXTGO
 354         STX TRAVEC
 355         TFR S,X ; Mechanical! Mechanical! (So the funn 6800 stack didn't beach us.)
 356         STX TRASP
 357         LDA #':'
 358         JSR PEMIT
 359 *       LDA #' '
 360 *       JSR PEMIT
 361         LDX W
 362         LEAX -1,X
 363         LEAX -1,X ; allocation link
 364         LEAX -1,X ; last char
 365         LDA #31
 366 NAMTST  LEAX -1,X ; length byte?
 367         LDB 0,X
 368         BMI NAMTDN
 369         DECA
 370         BNE NAMTST
 371 NAMTDN  ANDB #31 ; It's the length byte whether it wants to be or not.
 372 NAMSHW  LEAX 1,X
 373         LDA 0,X
 374         JSR PEMIT
 375         DECB
 376         BNE NAMSHW
 377 * show the virtual registers
 378 * TOO MUCH OUTPUT! Have to trim this.
 379         LDA #' '
 380         JSR PEMIT
 381         LDA #'@'
 382         LDX #TRAVEC
 383         JSR PHEX4F
 384         TFR DP,A
 385         LDB #(W-PGBASE)
 386         TFR D,X
 387         LDA #'W'
 388         JSR PHEX4F
 389         LDA #'I'
 390         JSR PHEX4F
 391         LDA #'R'
 392         JSR PHEX4F
 393         LDA #'U'
 394         JSR PHEX4F
 395         TFR DP,A
 396         LDB #(W-TRASP)
 397         TFR D,X
 398         LDA #'S'
 399         BSR PHEX4F
 400         LDA #'>'
 401         TFR S,X
 402         BSR PHEX4F
 403         LDA #' '
 404         BSR PHEX4F
 405 *
 406         JSR PRTCR
 407         LDX TRAVEC
 408 *
 409 NEXTGO  JMP     0,X
 410         NOP
 411 *       JMP     TRACE   ( an alternate for the above )
 412 *                                                                 =
 413 *                                                                 =
 414 *DBG
 415 PHEX4F  JSR PEMIT
 416         BSR PHEXX2
 417         BSR PHEXX2
 418         LDA #' '
 419         JMP PEMIT       ; rob return
 420 *
 421 PHEXX2  LDA 0,X
 422         LSRA
 423         LSRA
 424         LSRA
 425         LSRA
 426         BSR PHEXD
 427         LDA 0,X
 428         BSR PHEXD
 429         LEAX 1,X
 430         RTS
 431 *
 432 PHEXD   ANDA #$0F
 433         CMPA #10
 434         BLO PHEXDH
 435         ADDA #7 ; 'A'-'9'+1
 436 PHEXDH  ADDA #'0'
 437         JMP PEMIT       ; rob return
 438 *
 439 DEBUGP  FDB *+2
 440         INC FLAGON      my version of trace
 441         LDA FLAGON
 442         JSR PEMIT
 443         JMP NEXT
 444 *
 445 DEBUGM  FDB *+2
 446         DEC FLAGON      my version of trace
 447         LDA FLAGON
 448         JSR PEMIT
 449         JMP NEXT
 450 *DBG
 451 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
 452
 453
 454         PAGE
 455 *
 456 * ======>>  1  <<
 457         FCB     $83
 458         FCC     'LI'    ; 'LIT' :       NOTE: this is different from LITERAL
 459         FCB     $D4
 460         FDB     0       link of zero to terminate dictionary scan
 461 LIT     FDB     *+2
 462         LDX     IP
 463         LEAX 1,X
 464         LEAX 1,X
 465         STX     IP
 466         LDA     0,X
 467         LDB     1,X
 468         JMP     PUSHBA
 469 *
 470 * ######>> screen 14 <<
 471 * ======>>  2  <<
 472 CLITER  FDB     *+2      (this is an invisible word, with no header)
 473         LDX     IP
 474         LEAX 1,X
 475         STX     IP
 476         CLRA
 477         LDB     1,X
 478         JMP     PUSHBA
 479 *
 480 * ======>>  3  <<
 481         FCB     $87
 482         FCC     'EXECUT'        ; 'EXECUTE'
 483         FCB     $C5
 484         FDB     LIT-6
 485 EXEC    FDB     *+2
 486         TFR S,X
 487         LDX     0,X     get code field address (CFA)
 488         LEAS 1,S                pop stack
 489         LEAS 1,S
 490         JMP     NEXT3
 491 *
 492 * ######>> screen 15 <<
 493 * ======>>  4  <<
 494         FCB     $86
 495         FCC     'BRANC' ; 'BRANCH'
 496         FCB     $C8
 497         FDB     EXEC-10
 498 BRAN    FDB     ZBYES   Go steal code in ZBRANCH
 499 *
 500 * ======>>  5  <<
 501         FCB     $87
 502         FCC     '0BRANC'        ; '0BRANCH'
 503         FCB     $C8
 504         FDB     BRAN-9
 505 ZBRAN   FDB     *+2
 506         PULS A
 507         PULS B
 508 * ABA is only used here.
 509 * Could immediately convert PULs to LDD ,S++ ;
 510 * with no need for trailing BCS to look for overflow
 511 * because we are only testing for non-zero, but,
 512 * converting as if by unintelligent macro:
 513         PSHS B  ; LOL
 514         ADDA ,S+
 515 * End of unintelligent ABA conversion.
 516         BNE     ZBNO
 517         BCS     ZBNO
 518 ZBYES   LDX     IP      Note: code is shared with BRANCH, (+LOOP), (LOOP)
 519         LDB     3,X
 520         LDA     2,X
 521         ADDB    IP+1
 522         ADCA    IP
 523         STB     IP+1
 524         STA     IP
 525         JMP     NEXT
 526 ZBNO    LDX     IP      no branch. This code is shared with (+LOOP), (LOOP).
 527         LEAX 1,X                jump over branch delta
 528         LEAX 1,X
 529         STX     IP
 530         JMP     NEXT
 531 *
 532 * ######>> screen 16 <<
 533 * ======>>  6  <<
 534         FCB     $86
 535         FCC     '(LOOP' ; '(LOOP)'
 536         FCB     $A9
 537         FDB     ZBRAN-10
 538 XLOOP   FDB     *+2
 539         CLRA
 540         LDB     #1      get set to increment counter by 1
 541         BRA     XPLOP2  go steal other guy's code!
 542 *
 543 * ======>>  7  <<
 544         FCB     $87
 545         FCC     '(+LOOP'        ; '(+LOOP)'
 546         FCB     $A9
 547         FDB     XLOOP-9
 548 XPLOOP  FDB *+2 Note: +LOOP has an un-signed loop counter
 549         PULS A  get increment
 550         PULS B
 551 XPLOP2  TSTA
 552         BPL     XPLOF   forward looping
 553         BSR     XPLOPS
 554         ORCC #1
 555         SBCB    5,X
 556         SBCA    4,X
 557         BPL     ZBYES
 558         BRA     XPLONO  fall through
 559 *
 560 * the subroutine :
 561 XPLOPS  LDX     RP
 562         ADDB    3,X     add it to counter
 563         ADCA    2,X
 564         STB     3,X     store new counter value
 565         STA     2,X
 566         RTS
 567 *
 568 XPLOF   BSR     XPLOPS
 569         SUBB    5,X
 570         SBCA    4,X
 571         BMI     ZBYES
 572 *
 573 XPLONO  LEAX 1,X                done, don't branch back
 574         LEAX 1,X
 575         LEAX 1,X
 576         LEAX 1,X
 577         STX     RP
 578         BRA     ZBNO    use ZBRAN to skip over unused delta
 579 *
 580 * ######>> screen 17 <<
 581 * ======>>  8  <<
 582         FCB     $84
 583         FCC     '(DO'   ; '(DO)'
 584         FCB     $A9
 585         FDB     XPLOOP-10
 586 XDO     FDB     *+2     This is the RUNTIME DO, not the COMPILING DO
 587         LDX     RP
 588         LEAX -1,X
 589         LEAX -1,X
 590         LEAX -1,X
 591         LEAX -1,X
 592         STX     RP
 593         PULS A
 594         PULS B
 595         STA     2,X
 596         STB     3,X
 597         PULS A
 598         PULS B
 599         STA     4,X
 600         STB     5,X
 601         JMP     NEXT
 602 *
 603 * ======>>  9  <<
 604         FCB     $81     I
 605         FCB     $C9
 606         FDB     XDO-7
 607 I       FDB     *+2
 608         LDX     RP
 609         LEAX 1,X
 610         LEAX 1,X
 611         JMP     GETX
 612 *
 613 * ######>> screen 18 <<
 614 * ======>>  10  <<
 615         FCB     $85
 616         FCC     'DIGI'  ; 'DIGIT'
 617         FCB     $D4
 618         FDB     I-4
 619 DIGIT   FDB     *+2     NOTE: legal input range is 0-9, A-Z
 620         TFR S,X
 621         LDA     3,X
 622         SUBA    #$30    ascii zero
 623         BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
 624         CMPA    #$A
 625         BMI     DIGIT0  IF '9' OR LESS
 626         CMPA    #$11
 627         BMI     DIGIT2  if less than 'A'
 628         CMPA    #$2B
 629         BPL     DIGIT2  if greater than 'Z'
 630         SUBA    #7      translate 'A' thru 'F'
 631 DIGIT0  CMPA    1,X
 632         BPL     DIGIT2  if not less than the base
 633         LDB     #1      set flag
 634         STA     3,X     store digit
 635 DIGIT1  STB     1,X     store the flag
 636         JMP     NEXT
 637 DIGIT2  CLRB
 638         LEAS 1,S
 639         LEAS 1,S        pop bottom number
 640         TFR S,X
 641         STB     0,X     make sure both bytes are 00
 642         BRA     DIGIT1
 643 *
 644 * ######>> screen 19 <<
 645 *
 646 * The word format in the dictionary is:
 647 *
 648 * char-count + $80      lowest address
 649 * char 1
 650 * char 2
 651 *
 652 * char n  + $80
 653 * link high byte \___point to previous word
 654 * link low  byte /
 655 * CFA  high byte \___pnt to 6800 code
 656 * CFA  low  byte /
 657 * parameter fields
 658 *    "
 659 *    "
 660 *    "
 661 *
 662 * ======>>  11  <<
 663         FCB     $86
 664         FCC     '(FIND' ; '(FIND)'
 665         FCB     $A9
 666         FDB     DIGIT-8
 667 PFIND   FDB     *+2
 668         NOP
 669         NOP
 670 PD      EQU     N       ptr to dict word being checked
 671 PA0     EQU     N+2
 672 PA      EQU     N+4
 673 PCT     EQU     N+6     ; PC in 6800 source
 674         LDX     #PD
 675         LDB     #4
 676 PFIND0  PULS A          loop to get arguments
 677         STA     0,X
 678         LEAX 1,X
 679         DECB
 680         BNE     PFIND0
 681 *
 682         LDX     PD
 683 PFIND1  LDB     0,X     get count dict count
 684         STB     PCT
 685         ANDB    #$3F
 686         LEAX 1,X
 687         STX     PD      update PD
 688         LDX     PA0
 689         LDA     0,X     get count from arg
 690         LEAX 1,X
 691         STX     PA      intialize PA
 692         PSHS B ; sim CBA
 693         CMPA ,S+                compare lengths
 694         BNE     PFIND4
 695 PFIND2  LDX     PA
 696         LDA     0,X
 697         LEAX 1,X
 698         STX     PA
 699         LDX     PD
 700         LDB     0,X
 701         LEAX 1,X
 702         STX     PD
 703         TSTB            is dict entry neg. ?
 704         BPL     PFIND8
 705         ANDB    #$7F    clear sign
 706         PSHS B ; sim CBA
 707         CMPA ,S+
 708         BEQ     FOUND
 709 PFIND3  LDX     0,X     get new link
 710         BNE     PFIND1  continue if link not=0
 711 *
 712 *       not found :
 713 *
 714         CLRA
 715         CLRB
 716         JMP     PUSHBA
 717 PFIND8  PSHS B ; sim CBA
 718         CMPA ,S+
 719         BEQ     PFIND2
 720 PFIND4  LDX     PD
 721 PFIND9  LDB     0,X     scan forward to end of this name
 722         LEAX 1,X
 723         BPL     PFIND9
 724         BRA     PFIND3
 725 *
 726 *       found :
 727 *
 728 FOUND   LDA     PD      compute CFA
 729         LDB     PD+1
 730         ADDB    #4
 731         ADCA    #0
 732         PSHS B
 733         PSHS A
 734         LDA     PCT
 735         PSHS A
 736         CLRA
 737         PSHS A
 738         LDB     #1
 739         JMP     PUSHBA
 740 *
 741         PSHS A
 742         CLRA
 743         PSHS A
 744         LDB     #1
 745         JMP     PUSHBA
 746 *
 747 * ######>> screen 20 <<
 748 * ======>>  12  <<
 749         FCB     $87
 750         FCC     'ENCLOS'        ; 'ENCLOSE'
 751         FCB     $C5
 752         FDB     PFIND-9
 753 * NOTE :
 754 * FC means offset (bytes) to First Character of next word
 755 * EW  "     "   to End of Word
 756 * NC  "     "   to Next Character to start next enclose at
 757 ENCLOS  FDB     *+2
 758         LEAS 1,S
 759         PULS B          now, get the low byte, for an 8-bit delimiter
 760         TFR S,X
 761         LDX     0,X
 762         CLR     N
 763 *       wait for a non-delimiter or a NUL
 764 ENCL2   LDA     0,X
 765         BEQ     ENCL6
 766         PSHS B ; sim CBA
 767         CMPA ,S+                CHECK FOR DELIM
 768         BNE     ENCL3
 769         LEAX 1,X
 770         INC     N
 771         BRA     ENCL2
 772 *       found first character. Push FC
 773 ENCL3   LDA     N       found first char.
 774         PSHS A
 775         CLRA
 776         PSHS A
 777 *       wait for a delimiter or a NUL
 778 ENCL4   LDA     0,X
 779         BEQ     ENCL7
 780         PSHS B ; sim CBA
 781         CMPA ,S+                ckech for delim.
 782         BEQ     ENCL5
 783         LEAX 1,X
 784         INC     N
 785         BRA     ENCL4
 786 *       found EW. Push it
 787 ENCL5   LDB     N
 788         CLRA
 789         PSHS B
 790         PSHS A
 791 *       advance and push NC
 792         INCB
 793         JMP     PUSHBA
 794 *       found NUL before non-delimiter, therefore there is no word
 795 ENCL6   LDB     N       found NUL
 796         PSHS B
 797         PSHS A
 798         INCB
 799         BRA     ENCL7A  ; ENCL7+2 ******* was a *potential* bug ****** (But DP)
 800 *       found NUL following the word instead of SPACE
 801 ENCL7   LDB     N
 802 ENCL7A  PSHS B          save EW
 803         PSHS A
 804 ENCL8   LDB     N       save NC
 805         JMP     PUSHBA
 806
 807         PAGE
 808 *
 809 * ######>> screen 21 <<
 810 * The next 4 words call system dependant I/O routines
 811 * which are listed after word "-->" ( lable: "arrow" )
 812 * in the dictionary.
 813 *
 814 * ======>>  13  <<
 815         FCB     $84
 816         FCC     'EMI'   ; 'EMIT'
 817         FCB     $D4
 818         FDB     ENCLOS-10
 819 EMIT    FDB     *+2
 820         PULS A
 821         PULS A
 822         JSR     PEMIT
 823         LDX     UP
 824         INC     XOUT+1-UORIG,X
 825         BNE     EMITDN
 826         INC     XOUT-UORIG,X
 827 EMITDN  JMP     NEXT
 828 *
 829 * ======>>  14  <<
 830         FCB     $83
 831         FCC     'KE'    ; 'KEY'
 832         FCB     $D9
 833         FDB     EMIT-7
 834 KEY     FDB     *+2
 835         JSR     PKEY
 836         PSHS A
 837         CLRA
 838         PSHS A
 839         JMP     NEXT
 840 *
 841 * ======>>  15  <<
 842         FCB     $89
 843         FCC     '?TERMINA'      ; '?TERMINAL'
 844         FCB     $CC
 845         FDB     KEY-6
 846 QTERM   FDB     *+2
 847         JSR     PQTER
 848         CLRB
 849         JMP     PUSHBA  stack the flag
 850 *
 851 * ======>>  16  <<
 852         FCB     $82
 853         FCC     'C'     ; 'CR'
 854         FCB     $D2
 855         FDB     QTERM-12
 856 CR      FDB     *+2
 857         JSR     PRTCR
 858         JMP     NEXT
 859 *
 860 * ######>> screen 22 <<
 861 * ======>>  17  <<
 862         FCB     $85
 863         FCC     'CMOV'  ; 'CMOVE' :     source, destination, count
 864         FCB     $C5
 865         FDB     CR-5
 866 CMOVE   FDB     *+2     takes ( 43+47*count cycles )
 867         LDX     #N
 868         LDB     #6
 869 CMOV1   PULS A
 870         STA     0,X     move parameters to scratch area
 871         LEAX 1,X
 872         DECB
 873         BNE     CMOV1
 874 CMOV2   LDA     N
 875         LDB     N+1
 876         SUBB    #1
 877         SBCA    #0
 878         STA     N
 879         STB     N+1
 880         BCS     CMOV3
 881         LDX     N+4
 882         LDA     0,X
 883         LEAX 1,X
 884         STX     N+4
 885         LDX     N+2
 886         STA     0,X
 887         LEAX 1,X
 888         STX     N+2
 889         BRA     CMOV2
 890 CMOV3   JMP     NEXT
 891 *
 892 * ######>> screen 23 <<
 893 * ======>>  18  <<
 894         FCB     $82
 895         FCC     'U'     ; 'U*'
 896         FCB     $AA
 897         FDB     CMOVE-8
 898 USTAR   FDB     *+2
 899         BSR     USTARS
 900         LEAS 1,S
 901         LEAS 1,S
 902         JMP     PUSHBA
 903 *
 904 * The following is a subroutine which
 905 * multiplies top 2 words on stack,
 906 * leaving 32-bit result:  high order word in A,B
 907 * low order word in 2nd word of stack.
 908 *
 909 USTARS  LDA     #16     bits/word counter
 910         PSHS A
 911         CLRA
 912         CLRB
 913         TFR S,X
 914 USTAR2  ROR     5,X     shift multiplier
 915         ROR     6,X
 916         DEC     0,X     done?
 917         BMI     USTAR4
 918         BCC     USTAR3
 919         ADDB    4,X
 920         ADCA    3,X
 921 USTAR3  RORA
 922         RORB            ; shift result
 923         BRA     USTAR2
 924 USTAR4  LEAS 1,S                dump counter
 925         RTS
 926 *
 927 * ######>> screen 24 <<
 928 * ======>>  19  <<
 929         FCB     $82
 930         FCC     'U'     ; 'U/'
 931         FCB     $AF
 932         FDB     USTAR-5
 933 USLASH  FDB     *+2
 934         LDA     #17
 935         PSHS A
 936         TFR S,X
 937         LDA     3,X
 938         LDB     4,X
 939 USL1    CMPA    1,X
 940         BHI     USL3
 941         BCS     USL2
 942         CMPB    2,X
 943         BCC     USL3
 944 USL2    ANDCC #~1
 945         BRA     USL4
 946 USL3    SUBB    2,X
 947         SBCA    1,X
 948         ORCC #1
 949 USL4    ROL     6,X
 950         ROL     5,X
 951         DEC     0,X
 952         BEQ     USL5
 953         ROLB
 954         ROLA
 955         BCC     USL1
 956         BRA     USL3
 957 USL5    LEAS 1,S
 958         LEAS 1,S
 959         LEAS 1,S
 960         LEAS 1,S
 961         LEAS 1,S
 962         JMP     SWAP+4  reverse quotient & remainder
 963 *
 964 * ######>> screen 25 <<
 965 * ======>>  20  <<
 966         FCB     $83
 967         FCC     'AN'    ; 'AND'
 968         FCB     $C4
 969         FDB     USLASH-5
 970 AND     FDB     *+2
 971         PULS A
 972         PULS B
 973         TFR S,X
 974         ANDB    1,X
 975         ANDA    0,X
 976         JMP     STABX
 977 *
 978 * ======>>  21  <<
 979         FCB     $82
 980         FCC     'O'     ; 'OR'
 981         FCB     $D2
 982         FDB     AND-6
 983 OR      FDB     *+2
 984         PULS A
 985         PULS B
 986         TFR S,X
 987         ORB     1,X
 988         ORA     0,X
 989         JMP     STABX
 990 *
 991 * ======>>  22  <<
 992         FCB     $83
 993         FCC     'XO'    ; 'XOR'
 994         FCB     $D2
 995         FDB     OR-5
 996 XOR     FDB     *+2
 997         PULS A
 998         PULS B
 999         TFR S,X
1000         EORB    1,X
1001         EORA    0,X
1002         JMP     STABX
1003 *
1004 * ######>> screen 26 <<
1005 * ======>>  23  <<
1006         FCB     $83
1007         FCC     'SP'    ; 'SP@'
1008         FCB     $C0
1009         FDB     XOR-6
1010 SPAT    FDB     *+2
1011         TFR S,X
1012         STX     N       scratch area
1013         LDX     #N
1014         JMP     GETX
1015 *
1016 * ======>>  24  <<
1017         FCB     $83
1018         FCC     'SP'    ; 'SP!'
1019         FCB     $A1
1020         FDB     SPAT-6
1021 SPSTOR  FDB     *+2
1022         LDX     UP
1023         LDX     XSPZER-UORIG,X
1024 * Potential problem area? No. ******
1025         TFR X,S         watch it ! X and S are not equal -- on 6800.
1026 * But they are on 6809, and that's what we want here.
1027         JMP     NEXT
1028 * ======>>  25  <<
1029         FCB     $83
1030         FCC     'RP'    ; 'RP!'
1031         FCB     $A1
1032         FDB     SPSTOR-6
1033 RPSTOR  FDB     *+2
1034         LDX     RINIT   initialize from rom constant
1035         STX     RP
1036         JMP     NEXT
1037 *
1038 * ======>>  26  <<
1039         FCB     $82
1040         FCC     ';'     ; ';S'
1041         FCB     $D3
1042         FDB     RPSTOR-6
1043 SEMIS   FDB     *+2
1044 * DBG
1045         LDA #-$10
1046         ADDA FLAGON
1047         STA FLAGON      my version of trace
1048         JSR PEMIT
1049 *
1050         LDX     RP
1051         LEAX 1,X
1052         LEAX 1,X
1053         STX     RP
1054         LDX     0,X     get address we have just finished.
1055         JMP     NEXT+2  increment the return address & do next word
1056 *
1057 * ######>> screen 27 <<
1058 * ======>>  27  <<
1059         FCB     $85
1060         FCC     'LEAV'  ; 'LEAVE'
1061         FCB     $C5
1062         FDB     SEMIS-5
1063 LEAVE   FDB     *+2
1064         LDX     RP
1065         LDA     2,X
1066         LDB     3,X
1067         STA     4,X
1068         STB     5,X
1069         JMP     NEXT
1070 *
1071 * ======>>  28  <<
1072         FCB     $82
1073         FCC     '>'     ; '>R'
1074         FCB     $D2
1075         FDB     LEAVE-8
1076 TOR     FDB     *+2
1077         LDX     RP
1078         LEAX -1,X
1079         LEAX -1,X
1080         STX     RP
1081         PULS A
1082         PULS B
1083         STA     2,X
1084         STB     3,X
1085         JMP     NEXT
1086 *
1087 * ======>>  29  <<
1088         FCB     $82
1089         FCC     'R'     ; 'R>'
1090         FCB     $BE
1091         FDB     TOR-5
1092 FROMR   FDB     *+2
1093         LDX     RP
1094         LDA     2,X
1095         LDB     3,X
1096         LEAX 1,X
1097         LEAX 1,X
1098         STX     RP
1099         JMP     PUSHBA
1100 *
1101 * ======>>  30  <<
1102         FCB     $81     R
1103         FCB     $D2
1104         FDB     FROMR-5
1105 R       FDB     *+2
1106         LDX     RP
1107         LEAX 1,X
1108         LEAX 1,X
1109         JMP     GETX
1110 *
1111 * ######>> screen 28 <<
1112 * ======>>  31  <<
1113         FCB     $82
1114         FCC     '0'     ; '0='
1115         FCB     $BD
1116         FDB     R-4
1117 ZEQU    FDB     *+2
1118         TFR S,X
1119         CLRA
1120         CLRB
1121         LDX     0,X
1122         BNE     ZEQU2
1123         INCB
1124 ZEQU2   TFR S,X
1125         JMP     STABX
1126 *
1127 * ======>>  32  <<
1128         FCB     $82
1129         FCC     '0'     ; '0<'
1130         FCB     $BC
1131         FDB     ZEQU-5
1132 ZLESS   FDB     *+2
1133         TFR S,X
1134         LDA     #$80    check the sign bit
1135         ANDA    0,X
1136         BEQ     ZLESS2
1137         CLRA            if neg.
1138         LDB #1
1139         JMP     STABX
1140 ZLESS2  CLRB
1141         JMP     STABX
1142 *
1143 * ######>> screen 29 <<
1144 * ======>>  33  <<
1145         FCB     $81     '+'
1146         FCB     $AB
1147         FDB     ZLESS-5
1148 PLUS    FDB     *+2
1149         PULS A
1150         PULS B
1151         TFR S,X
1152         ADDB    1,X
1153         ADCA    0,X
1154         JMP     STABX
1155 *
1156 * ======>>  34  <<
1157         FCB     $82
1158         FCC     'D'     ; 'D+'
1159         FCB     $AB
1160         FDB     PLUS-4
1161 DPLUS   FDB     *+2
1162         TFR S,X
1163         ANDCC #~1
1164         LDB     #4
1165 DPLUS2  LDA     3,X
1166         ADCA    7,X
1167         STA     7,X
1168         LEAX -1,X
1169         DECB
1170         BNE     DPLUS2
1171         LEAS 1,S
1172         LEAS 1,S
1173         LEAS 1,S
1174         LEAS 1,S
1175         JMP     NEXT
1176 *
1177 * ======>>  35  <<
1178         FCB     $85
1179         FCC     'MINU'  ; 'MINUS'
1180         FCB     $D3
1181         FDB     DPLUS-5
1182 MINUS   FDB     *+2
1183         TFR S,X
1184         NEG     1,X
1185         BCC     MINUS2
1186         NEG     0,X
1187         BRA     MINUS3
1188 MINUS2  COM     0,X
1189 MINUS3  JMP     NEXT
1190 *
1191 * ======>>  36  <<
1192         FCB     $86
1193         FCC     'DMINU' ; 'DMINUS'
1194         FCB     $D3
1195         FDB     MINUS-8
1196 DMINUS  FDB     *+2
1197         TFR S,X
1198         COM     0,X
1199         COM     1,X
1200         COM     2,X
1201         NEG     3,X
1202         BNE     DMINX
1203         INC     2,X
1204         BNE     DMINX
1205         INC     1,X
1206         BNE     DMINX
1207         INC     0,X
1208 DMINX   JMP     NEXT
1209 *
1210 * ######>> screen 30 <<
1211 * ======>>  37  <<
1212         FCB     $84
1213         FCC     'OVE'   ; 'OVER'
1214         FCB     $D2
1215         FDB     DMINUS-9
1216 OVER    FDB     *+2
1217         TFR S,X
1218         LDA     2,X
1219         LDB     3,X
1220         JMP     PUSHBA
1221 *
1222 * ======>>  38  <<
1223         FCB     $84
1224         FCC     'DRO'   ; 'DROP'
1225         FCB     $D0
1226         FDB     OVER-7
1227 DROP    FDB     *+2
1228         LEAS 1,S
1229         LEAS 1,S
1230         JMP     NEXT
1231 *
1232 * ======>>  39  <<
1233         FCB     $84
1234         FCC     'SWA'   ; 'SWAP'
1235         FCB     $D0
1236         FDB     DROP-7
1237 SWAP    FDB     *+2
1238         PULS A
1239         PULS B
1240         TFR S,X
1241         LDX     0,X
1242         LEAS 1,S
1243         LEAS 1,S
1244         PSHS B
1245         PSHS A
1246         STX     N
1247         LDX     #N
1248         JMP     GETX
1249 *
1250 * ======>>  40  <<
1251         FCB     $83
1252         FCC     'DU'    ; 'DUP'
1253         FCB     $D0
1254         FDB     SWAP-7
1255 DUP     FDB     *+2
1256         PULS A
1257         PULS B
1258         PSHS B
1259         PSHS A
1260         JMP PUSHBA
1261 *
1262 * ######>> screen 31 <<
1263 * ======>>  41  <<
1264         FCB     $82
1265         FCC     '+'     ; '+!'
1266         FCB     $A1
1267         FDB     DUP-6
1268 PSTORE  FDB     *+2
1269         TFR S,X
1270         LDX     0,X
1271         LEAS 1,S
1272         LEAS 1,S
1273         PULS A          get stack data
1274         PULS B
1275         ADDB    1,X     add & store low byte
1276         STB     1,X
1277         ADCA    0,X     add & store hi byte
1278         STA     0,X
1279         JMP     NEXT
1280 *
1281 * ======>>  42  <<
1282         FCB     $86
1283         FCC     'TOGGL' ; 'TOGGLE'
1284         FCB     $C5
1285         FDB     PSTORE-5
1286 TOGGLE  FDB     DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1287         FDB     SEMIS
1288 *
1289 * ######>> screen 32 <<
1290 * ======>>  43  <<
1291         FCB     $81     @
1292         FCB     $C0
1293         FDB     TOGGLE-9
1294 AT      FDB     *+2
1295         TFR S,X
1296         LDX     0,X     get address
1297         LEAS 1,S
1298         LEAS 1,S
1299         JMP     GETX
1300 *
1301 * ======>>  44  <<
1302         FCB     $82
1303         FCC     'C'     ; 'C@'
1304         FCB     $C0
1305         FDB     AT-4
1306 CAT     FDB     *+2
1307         TFR S,X
1308         LDX     0,X
1309         CLRA
1310         LDB     0,X
1311         LEAS 1,S
1312         LEAS 1,S
1313         JMP     PUSHBA
1314 *
1315 * ======>>  45  <<
1316         FCB     $81
1317         FCB     $A1
1318         FDB     CAT-5
1319 STORE   FDB     *+2
1320         TFR S,X
1321         LDX     0,X     get address
1322         LEAS 1,S
1323         LEAS 1,S
1324         JMP     PULABX
1325 *
1326 * ======>>  46  <<
1327         FCB     $82
1328         FCC     'C'     ; 'C!'
1329         FCB     $A1
1330         FDB     STORE-4
1331 CSTORE  FDB     *+2
1332         TFR S,X
1333         LDX     0,X     get address
1334         LEAS 1,S
1335         LEAS 1,S
1336         LEAS 1,S
1337         PULS B
1338         STB     0,X
1339         JMP     NEXT
1340         PAGE
1341 *
1342 * ######>> screen 33 <<
1343 * ======>>  47  <<
1344         FCB     $C1     : immediate
1345         FCB     $BA
1346         FDB     CSTORE-5
1347 COLON   FDB     DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
1348         FDB     CREATE,RBRAK
1349         FDB     PSCODE
1350
1351 * Here is the IP pusher for allowing
1352 * nested words in the virtual machine:
1353 * ( ;S is the equivalent un-nester )
1354
1355 DOCOL   LDX     RP      make room in the stack
1356         LEAX -1,X
1357         LEAX -1,X
1358         STX     RP
1359 * DBG
1360         LDA #$10
1361         ADDA FLAGON
1362         STA FLAGON      my version of trace
1363         JSR PEMIT
1364 *
1365         LDA     IP
1366         LDB     IP+1
1367         STA     2,X     Store address of the high level word
1368         STB     3,X     that we are starting to execute
1369         LDX     W       Get first sub-word of that definition
1370         JMP     NEXT+2  and execute it
1371 *
1372 * ======>>  48  <<
1373         FCB     $C1     ;   imnediate code
1374         FCB     $BB
1375         FDB     COLON-4
1376 SEMI    FDB     DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
1377         FDB     SEMIS
1378 *
1379 * ######>> screen 34 <<
1380 * ======>>  49  <<
1381         FCB     $88
1382         FCC     'CONSTAN'       ; 'CONSTANT'
1383         FCB     $D4
1384         FDB     SEMI-4
1385 CON     FDB     DOCOL,CREATE,SMUDGE,COMMA,PSCODE
1386 DOCON   LDX     W
1387         LDA     2,X
1388         LDB     3,X     A & B now contain the constant
1389         JMP     PUSHBA
1390 *
1391 * ======>>  50  <<
1392         FCB     $88
1393         FCC     'VARIABL'       ; 'VARIABLE'
1394         FCB     $C5
1395         FDB     CON-11
1396 VAR     FDB     DOCOL,CON,PSCODE
1397 DOVAR   LDA     W
1398         LDB     W+1
1399         ADDB    #2
1400         ADCA    #0      A,B now contain the address of the variable
1401         JMP     PUSHBA
1402 *
1403 * ======>>  51  <<
1404         FCB     $84
1405         FCC     'USE'   ; 'USER'
1406         FCB     $D2
1407         FDB     VAR-11
1408 USER    FDB     DOCOL,CON,PSCODE
1409 DOUSER  LDX     W       get offset  into user's table
1410         LDA     2,X
1411         LDB     3,X
1412         ADDB    UP+1    add to users base address
1413         ADCA    UP
1414         JMP     PUSHBA  push address of user's variable
1415 *
1416 * ######>> screen 35 <<
1417 * ======>>  52  <<
1418         FCB     $81
1419         FCB     $B0     0
1420         FDB     USER-7
1421 ZERO    FDB     DOCON
1422         FDB     0000
1423 *
1424 * ======>>  53  <<
1425         FCB     $81
1426         FCB     $B1     1
1427         FDB     ZERO-4
1428 ONE     FDB     DOCON
1429         FDB     1
1430 *
1431 * ======>>  54  <<
1432         FCB     $81
1433         FCB     $B2     2
1434         FDB     ONE-4
1435 TWO     FDB     DOCON
1436         FDB     2
1437 *
1438 * ======>>  55  <<
1439         FCB     $81
1440         FCB     $B3     3
1441         FDB     TWO-4
1442 THREE   FDB     DOCON
1443         FDB     3
1444 *
1445 * ======>>  56  <<
1446         FCB     $82
1447         FCC     'B'     ; 'BL'
1448         FCB     $CC
1449         FDB     THREE-4
1450 BL      FDB     DOCON   ascii blank
1451         FDB     $20
1452 *
1453 * ======>>  57  <<
1454         FCB     $85
1455         FCC     'FIRS'  ; 'FIRST'
1456         FCB     $D4
1457         FDB     BL-5
1458 FIRST   FDB     DOCON
1459         FDB     MEMEND-528      (132 * NBLK)
1460 *
1461 * ======>>  58  <<
1462         FCB     $85
1463         FCC     'LIMI'  ; 'LIMIT' :     ( the end of memory +1 )
1464         FCB     $D4
1465         FDB     FIRST-8
1466 LIMIT   FDB     DOCON
1467         FDB     MEMEND
1468 *
1469 * ======>>  59  <<
1470         FCB     $85
1471         FCC     'B/BU'  ; 'B/BUF' :     (bytes/buffer)
1472         FCB     $C6
1473         FDB     LIMIT-8
1474 BBUF    FDB     DOCON
1475         FDB     128
1476 *
1477 * ======>>  60  <<
1478         FCB     $85
1479         FCC     'B/SC'  ; 'B/SCR' :     (blocks/screen)
1480         FCB     $D2
1481         FDB     BBUF-8
1482 BSCR    FDB     DOCON
1483         FDB     8
1484 *       blocks/screen = 1024 / "B/BUF" = 8
1485 *
1486 * ======>>  61  <<
1487         FCB     $87
1488         FCC     '+ORIGI'        ; '+ORIGIN'
1489         FCB     $CE
1490         FDB     BSCR-8
1491 PORIG   FDB     DOCOL,LIT,ORIG,PLUS
1492         FDB     SEMIS
1493 *
1494 * ######>> screen 36 <<
1495 * ======>>  62  <<
1496         FCB     $82
1497         FCC     'S'     ; 'S0'
1498         FCB     $B0
1499         FDB     PORIG-10
1500 SZERO   FDB     DOUSER
1501         FDB     XSPZER-UORIG
1502 *
1503 * ======>>  63  <<
1504         FCB     $82
1505         FCC     'R'     ; 'R0'
1506         FCB     $B0
1507         FDB     SZERO-5
1508 RZERO   FDB     DOUSER
1509         FDB     XRZERO-UORIG
1510 *
1511 * ======>>  64  <<
1512         FCB     $83
1513         FCC     'TI'    ; 'TIB'
1514         FCB     $C2
1515         FDB     RZERO-5
1516 TIB     FDB     DOUSER
1517         FDB     XTIB-UORIG
1518 *
1519 * ======>>  65  <<
1520         FCB     $85
1521         FCC     'WIDT'  ; 'WIDTH'
1522         FCB     $C8
1523         FDB     TIB-6
1524 WIDTH   FDB     DOUSER
1525         FDB     XWIDTH-UORIG
1526 *
1527 * ======>>  66  <<
1528         FCB     $87
1529         FCC     'WARNIN'        ; 'WARNING'
1530         FCB     $C7
1531         FDB     WIDTH-8
1532 WARN    FDB     DOUSER
1533         FDB     XWARN-UORIG
1534 *
1535 * ======>>  67  <<
1536         FCB     $85
1537         FCC     'FENC'  ; 'FENCE'
1538         FCB     $C5
1539         FDB     WARN-10
1540 FENCE   FDB     DOUSER
1541         FDB     XFENCE-UORIG
1542 *
1543 * ======>>  68  <<
1544         FCB     $82
1545         FCC     'D'     ; 'DP' :        points to first free byte at end of dictionary
1546         FCB     $D0
1547         FDB     FENCE-8
1548 DICPT   FDB     DOUSER  ; DP in 6800 source
1549         FDB     XDP-UORIG
1550 *
1551 * ======>>  68.5  <<
1552         FCB     $88
1553         FCC     'VOC-LIN'       ; 'VOC-LINK'
1554         FCB     $CB
1555         FDB     DICPT-5
1556 VOCLIN  FDB     DOUSER
1557         FDB     XVOCL-UORIG
1558 *
1559 * ======>>  69  <<
1560         FCB     $83
1561         FCC     'BL'    ; 'BLK'
1562         FCB     $CB
1563         FDB     VOCLIN-11
1564 BLK     FDB     DOUSER
1565         FDB     XBLK-UORIG
1566 *
1567 * ======>>  70  <<
1568         FCB     $82
1569         FCC     'I'     ; 'IN' :        scan pointer for input line buffer
1570         FCB     $CE
1571         FDB     BLK-6
1572 IN      FDB     DOUSER
1573         FDB     XIN-UORIG
1574 *
1575 * ======>>  71  <<
1576         FCB     $83
1577         FCC     'OU'    ; 'OUT'
1578         FCB     $D4
1579         FDB     IN-5
1580 OUT     FDB     DOUSER
1581         FDB     XOUT-UORIG
1582 *
1583 * ======>>  72  <<
1584         FCB     $83
1585         FCC     'SC'    ; 'SCR'
1586         FCB     $D2
1587         FDB     OUT-6
1588 SCR     FDB     DOUSER
1589         FDB     XSCR-UORIG
1590 * ######>> screen 37 <<
1591 *
1592 * ======>>  73  <<
1593         FCB     $86
1594         FCC     'OFFSE' ; 'OFFSET'
1595         FCB     $D4
1596         FDB     SCR-6
1597 OFSET   FDB     DOUSER
1598         FDB     XOFSET-UORIG
1599 *
1600 * ======>>  74  <<
1601         FCB     $87
1602         FCC     'CONTEX'        ; 'CONTEXT' :   points to pointer to vocab to search first
1603         FCB     $D4
1604         FDB     OFSET-9
1605 CONTXT  FDB     DOUSER
1606         FDB     XCONT-UORIG
1607 *
1608 * ======>>  75  <<
1609         FCB     $87
1610         FCC     'CURREN'        ; 'CURRENT' :   points to ptr. to vocab being extended
1611         FCB     $D4
1612         FDB     CONTXT-10
1613 CURENT  FDB     DOUSER
1614         FDB     XCURR-UORIG
1615 *
1616 * ======>>  76  <<
1617         FCB     $85
1618         FCC     'STAT'  ; 'STATE' :     1 if compiling, 0 if not
1619         FCB     $C5
1620         FDB     CURENT-10
1621 STATE   FDB     DOUSER
1622         FDB     XSTATE-UORIG
1623 *
1624 * ======>>  77  <<
1625         FCB     $84
1626         FCC     'BAS'   ; 'BASE' :      number base for all input & output
1627         FCB     $C5
1628         FDB     STATE-8
1629 BASE    FDB     DOUSER
1630         FDB     XBASE-UORIG
1631 *
1632 * ======>>  78  <<
1633         FCB     $83
1634         FCC     'DP'    ; 'DPL'
1635         FCB     $CC
1636         FDB     BASE-7
1637 DPL     FDB     DOUSER
1638         FDB     XDPL-UORIG
1639 *
1640 * ======>>  79  <<
1641         FCB     $83
1642         FCC     'FL'    ; 'FLD'
1643         FCB     $C4
1644         FDB     DPL-6
1645 FLD     FDB     DOUSER
1646         FDB     XFLD-UORIG
1647 *
1648 * ======>>  80  <<
1649         FCB     $83
1650         FCC     'CS'    ; 'CSP'
1651         FCB     $D0
1652         FDB     FLD-6
1653 CSP     FDB     DOUSER
1654         FDB     XCSP-UORIG
1655 *
1656 * ======>>  81  <<
1657         FCB     $82
1658         FCC     'R'     ; 'R#'
1659         FCB     $A3
1660         FDB     CSP-6
1661 RNUM    FDB     DOUSER
1662         FDB     XRNUM-UORIG
1663 *
1664 * ======>>  82  <<
1665         FCB     $83
1666         FCC     'HL'    ; 'HLD'
1667         FCB     $C4
1668         FDB     RNUM-5
1669 HLD     FDB     DOCON
1670         FDB     XHLD
1671 *
1672 * ======>>  82.5  <<== SPECIAL
1673         FCB     $87
1674         FCC     'COLUMN'        ; 'COLUMNS' :   line width of terminal
1675         FCB     $D3
1676         FDB     HLD-6
1677 COLUMS  FDB     DOUSER
1678         FDB     XCOLUM-UORIG
1679 *
1680 * ######>> screen 38 <<
1681 * ======>>  83  <<
1682         FCB     $82
1683         FCC     '1'     ; '1+'
1684         FCB     $AB
1685         FDB     COLUMS-10
1686 ONEP    FDB     DOCOL,ONE,PLUS
1687         FDB     SEMIS
1688 *
1689 * ======>>  84  <<
1690         FCB     $82
1691         FCC     '2'     ; '2+'
1692         FCB     $AB
1693         FDB     ONEP-5
1694 TWOP    FDB     DOCOL,TWO,PLUS
1695         FDB     SEMIS
1696 *
1697 * ======>>  85  <<
1698         FCB     $84
1699         FCC     'HER'   ; 'HERE'
1700         FCB     $C5
1701         FDB     TWOP-5
1702 HERE    FDB     DOCOL,DICPT,AT
1703         FDB     SEMIS
1704 *
1705 * ======>>  86  <<
1706         FCB     $85
1707         FCC     'ALLO'  ; 'ALLOT'
1708         FCB     $D4
1709         FDB     HERE-7
1710 ALLOT   FDB     DOCOL,DICPT,PSTORE
1711         FDB     SEMIS
1712 *
1713 * ======>>  87  <<
1714         FCB     $81     ; , (COMMA)
1715         FCB     $AC
1716         FDB     ALLOT-8
1717 COMMA   FDB     DOCOL,HERE,STORE,TWO,ALLOT
1718         FDB     SEMIS
1719 *
1720 * ======>>  88  <<
1721         FCB     $82
1722         FCC     'C'     ; 'C,'
1723         FCB     $AC
1724         FDB     COMMA-4
1725 CCOMM   FDB     DOCOL,HERE,CSTORE,ONE,ALLOT
1726         FDB     SEMIS
1727 *
1728 * ======>>  89  <<
1729         FCB     $81     ; -
1730         FCB     $AD
1731         FDB     CCOMM-5
1732 SUB     FDB     DOCOL,MINUS,PLUS
1733         FDB     SEMIS
1734 *
1735 * ======>>  90  <<
1736         FCB     $81     =
1737         FCB     $BD
1738         FDB     SUB-4
1739 EQUAL   FDB     DOCOL,SUB,ZEQU
1740         FDB     SEMIS
1741 *
1742 * ======>>  91  <<
1743         FCB     $81     <
1744         FCB     $BC
1745         FDB     EQUAL-4
1746 LESS    FDB     *+2
1747         PULS A
1748         PULS B
1749         TFR S,X
1750         CMPA    0,X
1751         LEAS 1,S
1752         BGT     LESST
1753         BNE     LESSF
1754         CMPB    1,X
1755         BHI     LESST
1756 LESSF   CLRB
1757         BRA     LESSX
1758 LESST   LDB     #1
1759 LESSX   CLRA
1760         LEAS 1,S
1761         JMP     PUSHBA
1762 *
1763 * ======>>  92  <<
1764         FCB     $81     >
1765         FCB     $BE
1766         FDB     LESS-4
1767 GREAT   FDB     DOCOL,SWAP,LESS
1768         FDB     SEMIS
1769 *
1770 * ======>>  93  <<
1771         FCB     $83
1772         FCC     'RO'    ; 'ROT'
1773         FCB     $D4
1774         FDB     GREAT-4
1775 ROT     FDB     DOCOL,TOR,SWAP,FROMR,SWAP
1776         FDB     SEMIS
1777 *
1778 * ======>>  94  <<
1779         FCB     $85
1780         FCC     'SPAC'  ; 'SPACE'
1781         FCB     $C5
1782         FDB     ROT-6
1783 SPACE   FDB     DOCOL,BL,EMIT
1784         FDB     SEMIS
1785 *
1786 * ======>>  95  <<
1787         FCB     $83
1788         FCC     'MI'    ; 'MIN'
1789         FCB     $CE
1790         FDB     SPACE-8
1791 MIN     FDB     DOCOL,OVER,OVER,GREAT,ZBRAN
1792         FDB     MIN2-*
1793         FDB     SWAP
1794 MIN2    FDB     DROP
1795         FDB     SEMIS
1796 *
1797 * ======>>  96  <<
1798         FCB     $83
1799         FCC     'MA'    ; 'MAX'
1800         FCB     $D8
1801         FDB     MIN-6
1802 MAX     FDB     DOCOL,OVER,OVER,LESS,ZBRAN
1803         FDB     MAX2-*
1804         FDB     SWAP
1805 MAX2    FDB     DROP
1806         FDB     SEMIS
1807 *
1808 * ======>>  97  <<
1809         FCB     $84
1810         FCC     '-DU'   ; '-DUP'
1811         FCB     $D0
1812         FDB     MAX-6
1813 DDUP    FDB     DOCOL,DUP,ZBRAN
1814         FDB     DDUP2-*
1815         FDB     DUP
1816 DDUP2   FDB     SEMIS
1817 *
1818 * ######>> screen 39 <<
1819 * ======>>  98  <<
1820         FCB     $88
1821         FCC     'TRAVERS'       ; 'TRAVERSE'
1822         FCB     $C5
1823         FDB     DDUP-7
1824 TRAV    FDB     DOCOL,SWAP
1825 TRAV2   FDB     OVER,PLUS,CLITER
1826         FCB     $7F
1827         FDB     OVER,CAT,LESS,ZBRAN
1828         FDB     TRAV2-*
1829         FDB     SWAP,DROP
1830         FDB     SEMIS
1831 *
1832 * ======>>  99  <<
1833         FCB     $86
1834         FCC     'LATES' ; 'LATEST'
1835         FCB     $D4
1836         FDB     TRAV-11
1837 LATEST  FDB     DOCOL,CURENT,AT,AT
1838         FDB     SEMIS
1839 *
1840 * ======>>  100  <<
1841         FCB     $83
1842         FCC     'LF'    ; 'LFA'
1843         FCB     $C1
1844         FDB     LATEST-9
1845 LFA     FDB     DOCOL,CLITER
1846         FCB     4
1847         FDB     SUB
1848         FDB     SEMIS
1849 *
1850 * ======>>  101  <<
1851         FCB     $83
1852         FCC     'CF'    ; 'CFA'
1853         FCB     $C1
1854         FDB     LFA-6
1855 CFA     FDB     DOCOL,TWO,SUB
1856         FDB     SEMIS
1857 *
1858 * ======>>  102  <<
1859         FCB     $83
1860         FCC     'NF'    ; 'NFA'
1861         FCB     $C1
1862         FDB     CFA-6
1863 NFA     FDB     DOCOL,CLITER
1864         FCB     5
1865         FDB     SUB,ONE,MINUS,TRAV
1866         FDB     SEMIS
1867 *
1868 * ======>>  103  <<
1869         FCB     $83
1870         FCC     'PF'    ; 'PFA'
1871         FCB     $C1
1872         FDB     NFA-6
1873 PFA     FDB     DOCOL,ONE,TRAV,CLITER
1874         FCB     5
1875         FDB     PLUS
1876         FDB     SEMIS
1877 *
1878 * ######>> screen 40 <<
1879 * ======>>  104  <<
1880         FCB     $84
1881         FCC     '!CS'   ; '!CSP'
1882         FCB     $D0
1883         FDB     PFA-6
1884 SCSP    FDB     DOCOL,SPAT,CSP,STORE
1885         FDB     SEMIS
1886 *
1887 * ======>>  105  <<
1888         FCB     $86
1889         FCC     '?ERRO' ; '?ERROR'
1890         FCB     $D2
1891         FDB     SCSP-7
1892 QERR    FDB     DOCOL,SWAP,ZBRAN
1893         FDB     QERR2-*
1894         FDB     ERROR,BRAN
1895         FDB     QERR3-*
1896 QERR2   FDB     DROP
1897 QERR3   FDB     SEMIS
1898 *
1899 * ======>>  106  <<
1900         FCB     $85
1901         FCC     '?COM'  ; '?COMP'
1902         FCB     $D0
1903         FDB     QERR-9
1904 QCOMP   FDB     DOCOL,STATE,AT,ZEQU,CLITER
1905         FCB     $11
1906         FDB     QERR
1907         FDB     SEMIS
1908 *
1909 * ======>>  107  <<
1910         FCB     $85
1911         FCC     '?EXE'  ; '?EXEC'
1912         FCB     $C3
1913         FDB     QCOMP-8
1914 QEXEC   FDB     DOCOL,STATE,AT,CLITER
1915         FCB     $12
1916         FDB     QERR
1917         FDB     SEMIS
1918 *
1919 * ======>>  108  <<
1920         FCB     $86
1921         FCC     '?PAIR' ; '?PAIRS'
1922         FCB     $D3
1923         FDB     QEXEC-8
1924 QPAIRS  FDB     DOCOL,SUB,CLITER
1925         FCB     $13
1926         FDB     QERR
1927         FDB     SEMIS
1928 *
1929 * ======>>  109  <<
1930         FCB     $84
1931         FCC     '?CS'   ; '?CSP'
1932         FCB     $D0
1933         FDB     QPAIRS-9
1934 QCSP    FDB     DOCOL,SPAT,CSP,AT,SUB,CLITER
1935         FCB     $14
1936         FDB     QERR
1937         FDB     SEMIS
1938 *
1939 * ======>>  110  <<
1940         FCB     $88
1941         FCC     '?LOADIN'       ; '?LOADING'
1942         FCB     $C7
1943         FDB     QCSP-7
1944 QLOAD   FDB     DOCOL,BLK,AT,ZEQU,CLITER
1945         FCB     $16
1946         FDB     QERR
1947         FDB     SEMIS
1948 *
1949 * ######>> screen 41 <<
1950 * ======>>  111  <<
1951         FCB     $87
1952         FCC     'COMPIL'        ; 'COMPILE'
1953         FCB     $C5
1954         FDB     QLOAD-11
1955 COMPIL  FDB     DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
1956         FDB     SEMIS
1957 *
1958 * ======>>  112  <<
1959         FCB     $C1     [       immediate
1960         FCB     $DB
1961         FDB     COMPIL-10
1962 LBRAK   FDB     DOCOL,ZERO,STATE,STORE
1963         FDB     SEMIS
1964 *
1965 * ======>>  113  <<
1966         FCB     $81     ]
1967         FCB     $DD
1968         FDB     LBRAK-4
1969 RBRAK   FDB     DOCOL,CLITER
1970         FCB     $C0
1971         FDB     STATE,STORE
1972         FDB     SEMIS
1973 *
1974 * ======>>  114  <<
1975         FCB     $86
1976         FCC     'SMUDG' ; 'SMUDGE'
1977         FCB     $C5
1978         FDB     RBRAK-4
1979 SMUDGE  FDB     DOCOL,LATEST,CLITER
1980         FCB     $20
1981         FDB     TOGGLE
1982         FDB     SEMIS
1983 *
1984 * ======>>  115  <<
1985         FCB     $83
1986         FCC     'HE'    ; 'HEX'
1987         FCB     $D8
1988         FDB     SMUDGE-9
1989 HEX     FDB     DOCOL
1990         FDB     CLITER
1991         FCB     16
1992         FDB     BASE,STORE
1993         FDB     SEMIS
1994 *
1995 * ======>>  116  <<
1996         FCB     $87
1997         FCC     'DECIMA'        ; 'DECIMAL'
1998         FCB     $CC
1999         FDB     HEX-6
2000 DECIM   FDB     DOCOL
2001         FDB     CLITER
2002         FCB     10      note: hex "A"
2003         FDB     BASE,STORE
2004         FDB     SEMIS
2005 *
2006 * ######>> screen 42 <<
2007 * ======>>  117  <<
2008         FCB     $87
2009         FCC     '(;CODE'        ; '(;CODE)'
2010         FCB     $A9
2011         FDB     DECIM-10
2012 PSCODE  FDB     DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
2013         FDB     SEMIS
2014 *
2015 * ======>>  118  <<
2016         FCB     $C5     immediate
2017         FCC     ';COD'  ; ';CODE'
2018         FCB     $C5
2019         FDB     PSCODE-10
2020 SEMIC   FDB     DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
2021         FDB     SEMIS
2022 * note: "QSTACK" will be replaced by "ASSEMBLER" later
2023 *
2024 * ######>> screen 43 <<
2025 * ======>>  119  <<
2026         FCB     $87
2027         FCC     '<BUILD'        ; '<BUILDS'
2028         FCB     $D3
2029         FDB     SEMIC-8
2030 BUILDS  FDB     DOCOL,ZERO,CON
2031         FDB     SEMIS
2032 *
2033 * ======>>  120  <<
2034         FCB     $85
2035         FCC     'DOES'  ; 'DOES>'
2036         FCB     $BE
2037         FDB     BUILDS-10
2038 DOES    FDB     DOCOL,FROMR,TWOP,LATEST,PFA,STORE
2039         FDB     PSCODE
2040 DODOES  LDA     IP
2041         LDB     IP+1
2042         LDX     RP      make room on return stack
2043         LEAX -1,X
2044         LEAX -1,X
2045         STX     RP
2046         STA     2,X     push return address
2047         STB     3,X
2048         LDX     W       get addr of pointer to run-time code
2049         LEAX 1,X
2050         LEAX 1,X
2051         STX     N       stash it in scratch area
2052         LDX     0,X     get new IP
2053         STX     IP
2054         CLRA            get address of parameter
2055         LDB     #2
2056         ADDB    N+1
2057         ADCA    N
2058         PSHS B          and push it on data stack
2059         PSHS A
2060         JMP     NEXT2
2061 *
2062 * ######>> screen 44 <<
2063 * ======>>  121  <<
2064         FCB     $85
2065         FCC     'COUN'  ; 'COUNT'
2066         FCB     $D4
2067         FDB     DOES-8
2068 COUNT   FDB     DOCOL,DUP,ONEP,SWAP,CAT
2069         FDB     SEMIS
2070 *
2071 * ======>>  122  <<
2072         FCB     $84
2073         FCC     'TYP'   ; 'TYPE'
2074         FCB     $C5
2075         FDB     COUNT-8
2076 TYPE    FDB     DOCOL,DDUP,ZBRAN
2077         FDB     TYPE3-*
2078         FDB     OVER,PLUS,SWAP,XDO
2079 TYPE2   FDB     I,CAT,EMIT,XLOOP
2080         FDB     TYPE2-*
2081         FDB     BRAN
2082         FDB     TYPE4-*
2083 TYPE3   FDB     DROP
2084 TYPE4   FDB     SEMIS
2085 *
2086 * ======>>  123  <<
2087         FCB     $89
2088         FCC     '-TRAILIN'      ; '-TRAILING'
2089         FCB     $C7
2090         FDB     TYPE-7
2091 DTRAIL  FDB     DOCOL,DUP,ZERO,XDO
2092 DTRAL2  FDB     OVER,OVER,PLUS,ONE,SUB,CAT,BL
2093         FDB     SUB,ZBRAN
2094         FDB     DTRAL3-*
2095         FDB     LEAVE,BRAN
2096         FDB     DTRAL4-*
2097 DTRAL3  FDB     ONE,SUB
2098 DTRAL4  FDB     XLOOP
2099         FDB     DTRAL2-*
2100         FDB     SEMIS
2101 *
2102 * ======>>  124  <<
2103         FCB     $84
2104         FCC     '(."'   ; '(.")'
2105         FCB     $A9
2106         FDB     DTRAIL-12
2107 PDOTQ   FDB     DOCOL,R,TWOP,COUNT,DUP,ONEP
2108         FDB     FROMR,PLUS,TOR,TYPE
2109         FDB     SEMIS
2110 *
2111 * ======>>  125  <<
2112         FCB     $C2     immediate
2113         FCC     '.'     ; '."'
2114         FCB     $A2
2115         FDB     PDOTQ-7
2116 DOTQ    FDB     DOCOL
2117         FDB     CLITER
2118         FCB     $22     ascii quote
2119         FDB     STATE,AT,ZBRAN
2120         FDB     DOTQ1-*
2121         FDB     COMPIL,PDOTQ,WORD
2122         FDB     HERE,CAT,ONEP,ALLOT,BRAN
2123         FDB     DOTQ2-*
2124 DOTQ1   FDB     WORD,HERE,COUNT,TYPE
2125 DOTQ2   FDB     SEMIS
2126 *
2127 * ######>> screen 45 <<
2128 * ======>>  126  <<== MACHINE DEPENDENT
2129         FCB     $86
2130         FCC     '?STAC' ; '?STACK'
2131         FCB     $CB
2132         FDB     DOTQ-5
2133 QSTACK  FDB     DOCOL,CLITER
2134         FCB     $12
2135         FDB     PORIG,AT,TWO,SUB,SPAT,LESS,ONE
2136         FDB     QERR
2137 * prints 'empty stack'
2138 *
2139 QSTAC2  FDB     SPAT
2140 * Here, we compare with a value at least 128
2141 * higher than dict. ptr. (DP)
2142         FDB     HERE,CLITER
2143         FCB     $80
2144         FDB     PLUS,LESS,ZBRAN
2145         FDB     QSTAC3-*
2146         FDB     TWO
2147         FDB     QERR
2148 * prints 'full stack'
2149 *
2150 QSTAC3  FDB     SEMIS
2151 *
2152 * ======>>  127  <<     this word's function
2153 *           is done by ?STACK in this version
2154 *       FCB     $85
2155 *       FCC     4,?FREE
2156 *       FCB     $C5
2157 *       FDB     QSTACK-9
2158 *QFREE  FDB     DOCOL,SPAT,HERE,CLITER
2159 *       FCB     $80
2160 *       FDB     PLUS,LESS,TWO,QERR,SEMIS
2161 *
2162 * ######>> screen 46 <<
2163 * ======>>  128  <<
2164         FCB     $86
2165         FCC     'EXPEC' ; 'EXPECT'
2166         FCB     $D4
2167         FDB     QSTACK-9
2168 EXPECT  FDB     DOCOL,OVER,PLUS,OVER,XDO
2169 EXPEC2  FDB     KEY,DUP,CLITER
2170         FCB     $0E
2171         FDB     PORIG,AT,EQUAL,ZBRAN
2172         FDB     EXPEC3-*
2173         FDB     DROP,CLITER
2174         FCB     8       ( backspace character to emit )
2175         FDB     OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
2176         FDB     TOR,SUB,BRAN
2177         FDB     EXPEC6-*
2178 EXPEC3  FDB     DUP,CLITER
2179         FCB     $D      ( carriage return )
2180         FDB     EQUAL,ZBRAN
2181         FDB     EXPEC4-*
2182         FDB     LEAVE,DROP,BL,ZERO,BRAN
2183         FDB     EXPEC5-*
2184 EXPEC4  FDB     DUP
2185 EXPEC5  FDB     I,CSTORE,ZERO,I,ONEP,STORE
2186 EXPEC6  FDB     EMIT,XLOOP
2187         FDB     EXPEC2-*
2188         FDB     DROP
2189         FDB     SEMIS
2190 *
2191 * ======>>  129  <<
2192         FCB     $85
2193         FCC     'QUER'  ; 'QUERY'
2194         FCB     $D9
2195         FDB     EXPECT-9
2196 QUERY   FDB     DOCOL,TIB,AT,COLUMS
2197         FDB     AT,EXPECT,ZERO,IN,STORE
2198         FDB     SEMIS
2199 *
2200 * ======>>  130  <<
2201         FCB     $C1     immediate       < carriage return >
2202         FCB     $80
2203         FDB     QUERY-8
2204 NULL    FDB     DOCOL,BLK,AT,ZBRAN
2205         FDB     NULL2-*
2206         FDB     ONE,BLK,PSTORE
2207         FDB     ZERO,IN,STORE,BLK,AT,BSCR,MOD
2208         FDB     ZEQU
2209 *     check for end of screen
2210         FDB     ZBRAN
2211         FDB     NULL1-*
2212         FDB     QEXEC,FROMR,DROP
2213 NULL1   FDB     BRAN
2214         FDB     NULL3-*
2215 NULL2   FDB     FROMR,DROP
2216 NULL3   FDB     SEMIS
2217 *
2218 * ######>> screen 47 <<
2219 * ======>>  133  <<
2220         FCB     $84
2221         FCC     'FIL'   ; 'FILL'
2222         FCB     $CC
2223         FDB     NULL-4
2224 FILL    FDB     DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
2225         FDB     FROMR,ONE,SUB,CMOVE
2226         FDB     SEMIS
2227 *
2228 * ======>>  134  <<
2229         FCB     $85
2230         FCC     'ERAS'  ; 'ERASE'
2231         FCB     $C5
2232         FDB     FILL-7
2233 ERASE   FDB     DOCOL,ZERO,FILL
2234         FDB     SEMIS
2235 *
2236 * ======>>  135  <<
2237         FCB     $86
2238         FCC     'BLANK' ; 'BLANKS'
2239         FCB     $D3
2240         FDB     ERASE-8
2241 BLANKS  FDB     DOCOL,BL,FILL
2242         FDB     SEMIS
2243 *
2244 * ======>>  136  <<
2245         FCB     $84
2246         FCC     'HOL'   ; 'HOLD'
2247         FCB     $C4
2248         FDB     BLANKS-9
2249 HOLD    FDB     DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
2250         FDB     SEMIS
2251 *
2252 * ======>>  137  <<
2253         FCB     $83
2254         FCC     'PA'    ; 'PAD'
2255         FCB     $C4
2256         FDB     HOLD-7
2257 PAD     FDB     DOCOL,HERE,CLITER
2258         FCB     $44
2259         FDB     PLUS
2260         FDB     SEMIS
2261 *
2262 * ######>> screen 48 <<
2263 * ======>>  138  <<
2264         FCB     $84
2265         FCC     'WOR'   ; 'WORD'
2266         FCB     $C4
2267         FDB     PAD-6
2268 WORD    FDB     DOCOL,BLK,AT,ZBRAN
2269         FDB     WORD2-*
2270         FDB     BLK,AT,BLOCK,BRAN
2271         FDB     WORD3-*
2272 WORD2   FDB     TIB,AT
2273 WORD3   FDB     IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
2274         FCB     34
2275         FDB     BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
2276         FDB     CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
2277         FDB     SEMIS
2278 *
2279 * ######>> screen 49 <<
2280 * ======>>  139  <<
2281         FCB     $88
2282         FCC     '(NUMBER'       ; '(NUMBER)'
2283         FCB     $A9
2284         FDB     WORD-7
2285 PNUMB   FDB     DOCOL
2286 PNUMB2  FDB     ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
2287         FDB     PNUMB4-*
2288         FDB     SWAP,BASE,AT,USTAR,DROP,ROT,BASE
2289         FDB     AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
2290         FDB     PNUMB3-*
2291         FDB     ONE,DPL,PSTORE
2292 PNUMB3  FDB     FROMR,BRAN
2293         FDB     PNUMB2-*
2294 PNUMB4  FDB     FROMR
2295         FDB     SEMIS
2296 *
2297 * ======>>  140  <<
2298         FCB     $86
2299         FCC     'NUMBE' ; 'NUMBER'
2300         FCB     $D2
2301         FDB     PNUMB-11
2302 NUMB    FDB     DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
2303         FCC     "-"     minus sign
2304         FDB     EQUAL,DUP,TOR,PLUS,LIT,$FFFF
2305 NUMB1   FDB     DPL,STORE,PNUMB,DUP,CAT,BL,SUB
2306         FDB     ZBRAN
2307         FDB     NUMB2-*
2308         FDB     DUP,CAT,CLITER
2309         FCC     "."
2310         FDB     SUB,ZERO,QERR,ZERO,BRAN
2311         FDB     NUMB1-*
2312 NUMB2   FDB     DROP,FROMR,ZBRAN
2313         FDB     NUMB3-*
2314         FDB     DMINUS
2315 NUMB3   FDB     SEMIS
2316 *
2317 * ======>>  141  <<
2318         FCB     $85
2319         FCC     '-FIN'  ; '-FIND'
2320         FCB     $C4
2321         FDB     NUMB-9
2322 DFIND   FDB     DOCOL,BL,WORD,HERE,CONTXT,AT,AT
2323         FDB     PFIND,DUP,ZEQU,ZBRAN
2324         FDB     DFIND2-*
2325         FDB     DROP,HERE,LATEST,PFIND
2326 DFIND2  FDB     SEMIS
2327 *
2328 * ######>> screen 50 <<
2329 * ======>>  142  <<
2330         FCB     $87
2331         FCC     '(ABORT'        ; '(ABORT)'
2332         FCB     $A9
2333         FDB     DFIND-8
2334 PABORT  FDB     DOCOL,ABORT
2335         FDB     SEMIS
2336 *
2337 * ======>>  143  <<
2338         FCB     $85
2339         FCC     'ERRO'  ; 'ERROR'
2340         FCB     $D2
2341         FDB     PABORT-10
2342 ERROR   FDB     DOCOL,WARN,AT,ZLESS
2343         FDB     ZBRAN
2344 * note: WARNING is -1 to abort, 0 to print error #
2345 * and 1 to print error message from disc
2346         FDB     ERROR2-*
2347         FDB     PABORT
2348 ERROR2  FDB     HERE,COUNT,TYPE,PDOTQ
2349         FCB     4,7     ( bell )
2350         FCC     " ? "
2351         FDB     MESS,SPSTOR,IN,AT,BLK,AT,QUIT
2352         FDB     SEMIS
2353 *
2354 * ======>>  144  <<
2355         FCB     $83
2356         FCC     'ID'    ; 'ID.'
2357         FCB     $AE
2358         FDB     ERROR-8
2359 IDDOT   FDB     DOCOL,PAD,CLITER
2360         FCB     32
2361         FDB     CLITER
2362         FCB     $5F     ( underline )
2363         FDB     FILL,DUP,PFA,LFA,OVER,SUB,PAD
2364         FDB     SWAP,CMOVE,PAD,COUNT,CLITER
2365         FCB     31
2366         FDB     AND,TYPE,SPACE
2367         FDB     SEMIS
2368 *
2369 * ######>> screen 51 <<
2370 * ======>>  145  <<
2371         FCB     $86
2372         FCC     'CREAT' ; 'CREATE'
2373         FCB     $C5
2374         FDB     IDDOT-6
2375 CREATE  FDB     DOCOL,DFIND,ZBRAN
2376         FDB     CREAT2-*
2377         FDB     DROP,PDOTQ
2378         FCB     8
2379         FCB     7       ( bel )
2380         FCC     "redef: "
2381         FDB     NFA,IDDOT,CLITER
2382         FCB     4
2383         FDB     MESS,SPACE
2384 CREAT2  FDB     HERE,DUP,CAT,WIDTH,AT,MIN
2385         FDB     ONEP,ALLOT,DUP,CLITER
2386         FCB     $A0
2387         FDB     TOGGLE,HERE,ONE,SUB,CLITER
2388         FCB     $80
2389         FDB     TOGGLE,LATEST,COMMA,CURENT,AT,STORE
2390         FDB     HERE,TWOP,COMMA
2391         FDB     SEMIS
2392 *
2393 * ######>> screen 52 <<
2394 * ======>>  146  <<
2395         FCB     $C9     immediate
2396         FCC     '[COMPILE'      ; '[COMPILE]'
2397         FCB     $DD
2398         FDB     CREATE-9
2399 BCOMP   FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
2400         FDB     SEMIS
2401 *
2402 * ======>>  147  <<
2403         FCB     $C7     immediate
2404         FCC     'LITERA'        ; 'LITERAL'
2405         FCB     $CC
2406         FDB     BCOMP-12
2407 LITER   FDB     DOCOL,STATE,AT,ZBRAN
2408         FDB     LITER2-*
2409         FDB     COMPIL,LIT,COMMA
2410 LITER2  FDB     SEMIS
2411 *
2412 * ======>>  148  <<
2413         FCB     $C8     immediate
2414         FCC     'DLITERA'       ; 'DLITERAL'
2415         FCB     $CC
2416         FDB     LITER-10
2417 DLITER  FDB     DOCOL,STATE,AT,ZBRAN
2418         FDB     DLITE2-*
2419         FDB     SWAP,LITER,LITER
2420 DLITE2  FDB     SEMIS
2421 *
2422 * ######>> screen 53 <<
2423 * ======>>  149  <<
2424         FCB     $89
2425         FCC     'INTERPRE'      ; 'INTERPRET'
2426         FCB     $D4
2427         FDB     DLITER-11
2428 INTERP  FDB     DOCOL
2429 INTER2  FDB     DFIND,ZBRAN
2430         FDB     INTER5-*
2431         FDB     STATE,AT,LESS
2432         FDB     ZBRAN
2433         FDB     INTER3-*
2434         FDB     CFA,COMMA,BRAN
2435         FDB     INTER4-*
2436 INTER3  FDB     CFA,EXEC
2437 INTER4  FDB     BRAN
2438         FDB     INTER7-*
2439 INTER5  FDB     HERE,NUMB,DPL,AT,ONEP,ZBRAN
2440         FDB     INTER6-*
2441         FDB     DLITER,BRAN
2442         FDB     INTER7-*
2443 INTER6  FDB     DROP,LITER
2444 INTER7  FDB     QSTACK,BRAN
2445         FDB     INTER2-*
2446 *       FDB     SEMIS   never executed
2447
2448 *
2449 * ######>> screen 54 <<
2450 * ======>>  150  <<
2451         FCB     $89
2452         FCC     'IMMEDIAT'      ; 'IMMEDIATE'
2453         FCB     $C5
2454         FDB     INTERP-12
2455 IMMED   FDB     DOCOL,LATEST,CLITER
2456         FCB     $40
2457         FDB     TOGGLE
2458         FDB     SEMIS
2459 *
2460 * ======>>  151  <<
2461         FCB     $8A
2462         FCC     'VOCABULAR'     ; 'VOCABULARY'
2463         FCB     $D9
2464         FDB     IMMED-12
2465 VOCAB   FDB     DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
2466         FDB     COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
2467 DOVOC   FDB     TWOP,CONTXT,STORE
2468         FDB     SEMIS
2469 *
2470 * ======>>  152  <<
2471 *
2472 * Note: FORTH does not go here in the rom-able dictionary,
2473 *    since FORTH is a type of variable.
2474 *
2475 *
2476 * ======>>  153  <<
2477         FCB     $8B
2478         FCC     'DEFINITION'    ; 'DEFINITIONS'
2479         FCB     $D3
2480         FDB     VOCAB-13
2481 DEFIN   FDB     DOCOL,CONTXT,AT,CURENT,STORE
2482         FDB     SEMIS
2483 *
2484 * ======>>  154  <<
2485         FCB     $C1     immediate       (
2486         FCB     $A8
2487         FDB     DEFIN-14
2488 PAREN   FDB     DOCOL,CLITER
2489         FCC     ")"
2490         FDB     WORD
2491         FDB     SEMIS
2492 *
2493 * ######>> screen 55 <<
2494 * ======>>  155  <<
2495         FCB     $84
2496         FCC     'QUI'   ; 'QUIT'
2497         FCB     $D4
2498         FDB     PAREN-4
2499 QUIT    FDB     DOCOL,ZERO,BLK,STORE
2500         FDB     LBRAK
2501 *
2502 *  Here is the outer interpretter
2503 *  which gets a line of input, does it, prints " OK"
2504 *  then repeats :
2505 QUIT2   FDB     RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
2506         FDB     ZBRAN
2507         FDB     QUIT3-*
2508         FDB     PDOTQ
2509         FCB     3
2510         FCC     ' OK'   ; ' OK'
2511 QUIT3   FDB     BRAN
2512         FDB     QUIT2-*
2513 *       FDB     SEMIS   ( never executed )
2514 *
2515 * ======>>  156  <<
2516         FCB     $85
2517         FCC     'ABOR'  ; 'ABORT'
2518         FCB     $D4
2519         FDB     QUIT-7
2520 ABORT   FDB     DOCOL,SPSTOR,DECIM,QSTACK,DRZERO,CR,PDOTQ
2521         FCB     15
2522         FCC     "Forth-68oo-68o9"
2523         FDB     FORTH,DEFIN
2524         FDB     QUIT
2525 *       FDB     SEMIS   never executed
2526         PAGE
2527 *
2528 * ######>> screen 56 <<
2529 * bootstrap code... moves rom contents to ram :
2530 * ======>>  157  <<
2531         FCB     $84
2532         FCC     'COL'   ; 'COLD'
2533         FCB     $C4
2534         FDB     ABORT-8
2535 COLD    FDB     *+2
2536 * CENT  LDS     #REND-1 top of destination on 6800
2537 CENT    LDA #PGBDP
2538         TFR A,DP
2539         LDS     #REND   top of destination on 6809
2540         LDX     #ERAM   top of stuff to move
2541 COLD2   LEAX -1,X
2542         LDA     0,X
2543         PSHS A          move TASK & FORTH to ram
2544         CMPX    #RAM
2545         BNE     COLD2
2546 *
2547 *       LDS     #XFENCE-1       put stack at a safe place for now -- 6800
2548 * But only matters if we're interrupted.
2549         LDS     #XFENCE         put stack at a safe place for now -- 6809
2550         LDX     COLINT
2551         STX     XCOLUM
2552         LDX     DELINT
2553         STX     XDELAY
2554         LDX     VOCINT
2555         STX     XVOCL
2556         LDX     DPINIT
2557         STX     XDP
2558         LDX     FENCIN
2559         STX     XFENCE
2560
2561
2562 * WENT  LDS     #XFENCE-1       top of destination -- 6800
2563 WENT    LDS     #XFENCE         top of destination -- 6809
2564         LDX     #FENCIN         top of stuff to move
2565 WARM2   LEAX -1,X
2566         LDA     0,X
2567         PSHS A
2568         CMPX    #SINIT
2569         BNE     WARM2
2570 *
2571 * Don't get faked out.
2572 * This is just a safe place for the stack if we're interrupted.
2573 * ABORT sends us through RP! and then SP!
2574 * And SP! loads S through X, which is just fine for the 6809, too.
2575         LDS     SINIT
2576         LDX     UPINIT
2577         STX     UP              init user ram pointer
2578         LDX     #ABORT
2579         STX     IP
2580         NOP             Here is a place to jump to special user
2581         NOP             initializations such as I/0 interrups
2582         NOP
2583 *
2584 * For systems with TRACE:
2585         LDX     #00
2586         STX     TRLIM   clear trace mode
2587         LDX     #0
2588         STX     BRKPT   clear breakpoint address
2589 * DBG
2590         LDA #$21
2591         STA FLAGON      my version of trace
2592         JSR PEMIT
2593 *
2594         JMP     RPSTOR+2 start the virtual machine running !
2595 *
2596 * Here is the stuff that gets copied to ram :
2597 * at address $140:
2598 *
2599 RAM     FDB     $5000,$5000,0,0
2600
2601 * ======>>  (152)  <<
2602         FCB     $C5     immediate
2603         FCC     'FORT'  ; 'FORTH'
2604         FCB     $C8
2605         FDB     NOOP-7
2606 RFORTH  FDB     DODOES,DOVOC,$81A0,TASK-7
2607         FDB     0
2608         FCC     "(C) Forth Interest Group, 1979"
2609         FCB     $84
2610         FCC     'TAS'   ; 'TASK'
2611         FCB     $CB
2612         FDB     FORTH-8
2613 RTASK   FDB     DOCOL,SEMIS
2614 ERAM    FCC     "David Lion"
2615         PAGE
2616 *
2617 * ######>> screen 57 <<
2618 * ======>>  158  <<
2619         FCB     $84
2620         FCC     'S->'   ; 'S->D'
2621         FCB     $C4
2622         FDB     COLD-7
2623 STOD    FDB     DOCOL,DUP,ZLESS,MINUS
2624         FDB     SEMIS
2625
2626
2627 *
2628 * ======>>  159  <<
2629         FCB     $81     ; *
2630         FCB     $AA
2631         FDB     STOD-7
2632 STAR    FDB     *+2
2633         JSR     USTARS
2634         LEAS 1,S
2635         LEAS 1,S
2636         JMP     NEXT
2637 *
2638 * ======>>  160  <<
2639         FCB     $84
2640         FCC     '/MO'   ; '/MOD'
2641         FCB     $C4
2642         FDB     STAR-4
2643 SLMOD   FDB     DOCOL,TOR,STOD,FROMR,USLASH
2644         FDB     SEMIS
2645 *
2646 * ======>>  161  <<
2647         FCB     $81     ; /
2648         FCB     $AF
2649         FDB     SLMOD-7
2650 SLASH   FDB     DOCOL,SLMOD,SWAP,DROP
2651         FDB     SEMIS
2652 *
2653 * ======>>  162  <<
2654         FCB     $83
2655         FCC     'MO'    ; 'MOD'
2656         FCB     $C4
2657         FDB     SLASH-4
2658 MOD     FDB     DOCOL,SLMOD,DROP
2659         FDB     SEMIS
2660 *
2661 * ======>>  163  <<
2662         FCB     $85
2663         FCC     '*/MO'  ; '*/MOD'
2664         FCB     $C4
2665         FDB     MOD-6
2666 SSMOD   FDB     DOCOL,TOR,USTAR,FROMR,USLASH
2667         FDB     SEMIS
2668 *
2669 * ======>>  164  <<
2670         FCB     $82
2671         FCC     '*'     ; '*/'
2672         FCB     $AF
2673         FDB     SSMOD-8
2674 SSLASH  FDB     DOCOL,SSMOD,SWAP,DROP
2675         FDB     SEMIS
2676 *
2677 * ======>>  165  <<
2678         FCB     $85
2679         FCC     'M/MO'  ; 'M/MOD'
2680         FCB     $C4
2681         FDB     SSLASH-5
2682 MSMOD   FDB     DOCOL,TOR,ZERO,R,USLASH
2683         FDB     FROMR,SWAP,TOR,USLASH,FROMR
2684         FDB     SEMIS
2685 *
2686 * ======>>  166  <<
2687         FCB     $83
2688         FCC     'AB'    ; 'ABS'
2689         FCB     $D3
2690         FDB     MSMOD-8
2691 ABS     FDB     DOCOL,DUP,ZLESS,ZBRAN
2692         FDB     ABS2-*
2693         FDB     MINUS
2694 ABS2    FDB     SEMIS
2695 *
2696 * ======>>  167  <<
2697         FCB     $84
2698         FCC     'DAB'   ; 'DABS'
2699         FCB     $D3
2700         FDB     ABS-6
2701 DABS    FDB     DOCOL,DUP,ZLESS,ZBRAN
2702         FDB     DABS2-*
2703         FDB     DMINUS
2704 DABS2   FDB     SEMIS
2705 *
2706 * ######>> screen 58 <<
2707 * Disc primatives :
2708 * ======>>  168  <<
2709         FCB     $83
2710         FCC     'US'    ; 'USE'
2711         FCB     $C5
2712         FDB     DABS-7
2713 USE     FDB     DOCON
2714         FDB     XUSE
2715 * ======>>  169  <<
2716         FCB     $84
2717         FCC     'PRE'   ; 'PREV'
2718         FCB     $D6
2719         FDB     USE-6
2720 PREV    FDB     DOCON
2721         FDB     XPREV
2722 * ======>>  170  <<
2723         FCB     $84
2724         FCC     '+BU'   ; '+BUF'
2725         FCB     $C6
2726         FDB     PREV-7
2727 PBUF    FDB     DOCOL,CLITER
2728         FCB     $84
2729         FDB     PLUS,DUP,LIMIT,EQUAL,ZBRAN
2730         FDB     PBUF2-*
2731         FDB     DROP,FIRST
2732 PBUF2   FDB     DUP,PREV,AT,SUB
2733         FDB     SEMIS
2734 *
2735 * ======>>  171  <<
2736         FCB     $86
2737         FCC     'UPDAT' ; 'UPDATE'
2738         FCB     $C5
2739         FDB     PBUF-7
2740 UPDATE  FDB     DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
2741         FDB     SEMIS
2742 *
2743 * ======>>  172  <<
2744         FCB     $8D
2745         FCC     'EMPTY-BUFFER'  ; 'EMPTY-BUFFERS'
2746         FCB     $D3
2747         FDB     UPDATE-9
2748 MTBUF   FDB     DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
2749         FDB     SEMIS
2750 *
2751 * ======>>  173  <<
2752         FCB     $83
2753         FCC     'DR'    ; 'DR0'
2754         FCB     $B0
2755         FDB     MTBUF-16
2756 DRZERO  FDB     DOCOL,ZERO,OFSET,STORE
2757         FDB     SEMIS
2758 *
2759 * ======>>  174  <<== system dependant word
2760         FCB     $83
2761         FCC     'DR'    ; 'DR1'
2762         FCB     $B1
2763         FDB     DRZERO-6
2764 DRONE   FDB     DOCOL,LIT,$07D0,OFSET,STORE
2765         FDB     SEMIS
2766 *
2767 * ######>> screen 59 <<
2768 * ======>>  175  <<
2769         FCB     $86
2770         FCC     'BUFFE' ; 'BUFFER'
2771         FCB     $D2
2772         FDB     DRONE-6
2773 BUFFER  FDB     DOCOL,USE,AT,DUP,TOR
2774 BUFFR2  FDB     PBUF,ZBRAN
2775         FDB     BUFFR2-*
2776         FDB     USE,STORE,R,AT,ZLESS
2777         FDB     ZBRAN
2778         FDB     BUFFR3-*
2779         FDB     R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
2780 BUFFR3  FDB     R,STORE,R,PREV,STORE,FROMR,TWOP
2781         FDB     SEMIS
2782 *
2783 * ######>> screen 60 <<
2784 * ======>>  176  <<
2785         FCB     $85
2786         FCC     'BLOC'  ; 'BLOCK'
2787         FCB     $CB
2788         FDB     BUFFER-9
2789 BLOCK   FDB     DOCOL,OFSET,AT,PLUS,TOR
2790         FDB     PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
2791         FDB     BLOCK5-*
2792 BLOCK3  FDB     PBUF,ZEQU,ZBRAN
2793         FDB     BLOCK4-*
2794         FDB     DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
2795 BLOCK4  FDB     DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
2796         FDB     BLOCK3-*
2797         FDB     DUP,PREV,STORE
2798 BLOCK5  FDB     FROMR,DROP,TWOP
2799         FDB     SEMIS
2800 *
2801 * ######>> screen 61 <<
2802 * ======>>  177  <<
2803         FCB     $86
2804         FCC     '(LINE' ; '(LINE)'
2805         FCB     $A9
2806         FDB     BLOCK-8
2807 PLINE   FDB     DOCOL,TOR,CLITER
2808         FCB     $40
2809         FDB     BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
2810         FCB     $40
2811         FDB     SEMIS
2812 *
2813 * ======>>  178  <<
2814         FCB     $85
2815         FCC     '.LIN'  ; '.LINE'
2816         FCB     $C5
2817         FDB     PLINE-9
2818 DLINE   FDB     DOCOL,PLINE,DTRAIL,TYPE
2819         FDB     SEMIS
2820 *
2821 * ======>>  179  <<
2822         FCB     $87
2823         FCC     'MESSAG'        ; 'MESSAGE'
2824         FCB     $C5
2825         FDB     DLINE-8
2826 MESS    FDB     DOCOL,WARN,AT,ZBRAN
2827         FDB     MESS3-*
2828         FDB     DDUP,ZBRAN
2829         FDB     MESS3-*
2830         FDB     CLITER
2831         FCB     4
2832         FDB     OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
2833         FDB     MESS4-*
2834 MESS3   FDB     PDOTQ
2835         FCB     6
2836         FCC     'err # '        ; 'err # '
2837         FDB     DOT
2838 MESS4   FDB     SEMIS
2839 *
2840 * ======>>  180  <<
2841         FCB     $84
2842         FCC     'LOA'   ; 'LOAD' :      input:scr #
2843         FCB     $C4
2844         FDB     MESS-10
2845 LOAD    FDB     DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
2846         FDB     BSCR,STAR,BLK,STORE
2847         FDB     INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
2848         FDB     SEMIS
2849 *
2850 * ======>>  181  <<
2851         FCB     $C3
2852         FCC     '--'    ; '-->'
2853         FCB     $BE
2854         FDB     LOAD-7
2855 ARROW   FDB     DOCOL,QLOAD,ZERO,IN,STORE,BSCR
2856         FDB     BLK,AT,OVER,MOD,SUB,BLK,PSTORE
2857         FDB     SEMIS
2858         PAGE
2859 *
2860 *
2861 * ######>> screen 63 <<
2862 *    The next 4 subroutines are machine dependent, and are
2863 *    called by words 13 through 16 in the dictionary.
2864 *
2865 * ======>>  182  << code for EMIT
2866 *    character to output in A
2867 * Coco:
2868 PEMIT   PSHS Y,U,DP
2869         CLRB
2870         TFR B,DP
2871         JSR [$A002]
2872         PULS Y,U,DP,PC
2873 *
2874 * PEMIT STB     N       save B
2875 *       STX     N+1     save X
2876 *       LDB     ACIAC
2877 *       BITB    #2      check ready bit
2878 *       BEQ     PEMIT+4 if not ready for more data
2879 *       STA     ACIAD
2880 *       LDX     UP
2881 *       STB     IOSTAT-UORIG,X
2882 *       LDB     N       recover B & X
2883 *       LDX     N+1
2884 *       RTS             only A register may change
2885 *  PEMIT        JMP     $E1D1   for MIKBUG
2886 *  PEMIT        FCB     $3F,$11,$39     for PROTO
2887 *  PEMIT        JMP     $D286 for Smoke Signal DOS
2888 *
2889 * ======>>  183  << code for KEY
2890 * Returns input character in A
2891 * Coco:
2892 PKEY    PSHS Y,U,DP
2893         CLRB
2894         TFR B,DP
2895         LDA #$CF a cursor
2896         LDB [$0088] (locate) save
2897         STA [$0088]
2898 PKEYBZ  JSR [$A000]
2899         BEQ PKEYBZ
2900         STB [$0088] restore
2901         PULS Y,U,DP,PC
2902 *
2903 * PKEY  STB     N
2904 *       STX     N+1
2905 *       LDB     ACIAC
2906 *       ASRB
2907 *       BCC     PKEY+4  no incoming data yet
2908 *       LDA     ACIAD
2909 *       ANDA    #$7F    strip parity bit
2910 *       LDX     UP
2911 *       STB     IOSTAT+1-UORIG,X
2912 *       LDB     N
2913 *       LDX     N+1
2914 *       RTS
2915 *  PKEY JMP     $E1AC   for MIKBUG
2916 *  PKEY FCB     $3F,$14,$39     for PROTO
2917 *  PKEY JMP     $D289 for Smoke Signal DOS
2918 *
2919 * ######>> screen 64 <<
2920 * ======>>  184  << code for ?TERMINAL
2921 * Returns flag in A (non-zero if BREAK).
2922 * Coco:
2923 PQTER   PSHS Y,U,DP
2924         CLRB
2925         TFR B,DP
2926         JSR [$A000]
2927         CLRB
2928         CMPA #3 break key
2929         BNE PQTERN
2930         INCB
2931         EXG A,B
2932 PQTERN  PULS Y,U,DP,PC
2933 *
2934 * PQTER LDA     ACIAC   Test for 'break'  condition
2935 *       ANDA    #$11    mask framing error bit and
2936 **                      input buffer full
2937 *       BEQ     PQTER2
2938 *       LDA     ACIAD   clear input buffer
2939 *       LDA     #01
2940 *PQTER2 RTS
2941
2942
2943         PAGE
2944 *
2945 * ======>>  185  << code for CR
2946 * Coco:
2947 PRTCR   LDA     #$D     carriage return ; PCR in 6800 source
2948         BRA     PEMIT   Let PEMIT return
2949 *
2950 *       BSR     PEMIT
2951 *       LDA     #$A     line feed
2952 *       BSR     PEMIT
2953 *       LDA     #$7F    rubout
2954 *       LDX     UP
2955 *       LDB     XDELAY+1-UORIG,X
2956 * PCR2  DECB
2957 *       BMI     PQTER2  return if minus
2958 *       PSHS B          save counter
2959 *       BSR     PEMIT   print RUBOUTs to delay.....
2960 *       PULS B
2961 *       BRA     PCR2    repeat
2962
2963
2964         PAGE
2965 *
2966 * ######>> screen 66 <<
2967 * ======>>  187  <<
2968         FCB     $85
2969         FCC     '?DIS'  ; '?DISC'
2970         FCB     $C3
2971         FDB     ARROW-6
2972 QDISC   FDB     *+2
2973         JMP     NEXT
2974 *
2975 * ######>> screen 67 <<
2976 * ======>>  189  <<
2977         FCB     $8B
2978         FCC     'BLOCK-WRIT'    ; 'BLOCK-WRITE'
2979         FCB     $C5
2980         FDB     QDISC-8
2981 BWRITE  FDB     *+2
2982         JMP     NEXT
2983 *
2984 * ######>> screen 68 <<
2985 * ======>>  190  <<
2986         FCB     $8A
2987         FCC     'BLOCK-REA'     ; 'BLOCK-READ'
2988         FCB     $C4
2989         FDB     BWRITE-14
2990 BREAD   FDB     *+2
2991         JMP     NEXT
2992 *
2993 *The next 3 words are written to create a substitute for disc
2994 * mass memory,located between $3210 & $3FFF in ram.
2995 * ======>>  190.1  <<
2996         FCB     $82
2997         FCC     'L'     ; 'LO'
2998         FCB     $CF
2999         FDB     BREAD-13
3000 LO      FDB     DOCON
3001         FDB     MEMEND  a system dependent equate at front
3002 *
3003 * ======>>  190.2  <<
3004         FCB     $82
3005         FCC     'H'     ; 'HI'
3006         FCB     $C9
3007         FDB     LO-5
3008 HI      FDB     DOCON
3009         FDB     MEMTOP  ( $3FFF in this version )
3010 *
3011 * ######>> screen 69 <<
3012 * ======>>  191  <<
3013         FCB     $83
3014         FCC     'R/'    ; 'R/W'
3015         FCB     $D7
3016         FDB     HI-5
3017 RW      FDB     DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
3018         FDB     RW2-*
3019         FDB     PDOTQ
3020         FCB     8
3021         FCC     ' Range ?'      ; ' Range ?'
3022         FDB     QUIT
3023 RW2     FDB     FROMR,ZBRAN
3024         FDB     RW3-*
3025         FDB     SWAP
3026 RW3     FDB     BBUF,CMOVE
3027         FDB     SEMIS
3028 *
3029 * ######>> screen 72 <<
3030 * ======>>  192  <<
3031         FCB     $C1     immediate
3032         FCB     $A7     '       ( tick )
3033         FDB     RW-6
3034 TICK    FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
3035         FDB     SEMIS
3036 *
3037 * ======>>  193  <<
3038         FCB     $86
3039         FCC     'FORGE' ; 'FORGET'
3040         FCB     $D4
3041         FDB     TICK-4
3042 FORGET  FDB     DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
3043         FCB     $18
3044         FDB     QERR,TICK,DUP,FENCE,AT,LESS,CLITER
3045         FCB     $15
3046         FDB     QERR,DUP,ZERO,PORIG,GREAT,CLITER
3047         FCB     $15
3048         FDB     QERR,DUP,NFA,DICPT,STORE,LFA,AT,CONTXT,AT,STORE
3049         FDB     SEMIS
3050 *
3051 * ######>> screen 73 <<
3052 * ======>>  194  <<
3053         FCB     $84
3054         FCC     'BAC'   ; 'BACK'
3055         FCB     $CB
3056         FDB     FORGET-9
3057 BACK    FDB     DOCOL,HERE,SUB,COMMA
3058         FDB     SEMIS
3059 *
3060 * ======>>  195  <<
3061         FCB     $C5
3062         FCC     'BEGI'  ; 'BEGIN'
3063         FCB     $CE
3064         FDB     BACK-7
3065 BEGIN   FDB     DOCOL,QCOMP,HERE,ONE
3066         FDB     SEMIS
3067 *
3068 * ======>>  196  <<
3069         FCB     $C5
3070         FCC     'ENDI'  ; 'ENDIF'
3071         FCB     $C6
3072         FDB     BEGIN-8
3073 ENDIF   FDB     DOCOL,QCOMP,TWO,QPAIRS,HERE
3074         FDB     OVER,SUB,SWAP,STORE
3075         FDB     SEMIS
3076 *
3077 * ======>>  197  <<
3078         FCB     $C4
3079         FCC     'THE'   ; 'THEN'
3080         FCB     $CE
3081         FDB     ENDIF-8
3082 THEN    FDB     DOCOL,ENDIF
3083         FDB     SEMIS
3084 *
3085 * ======>>  198  <<
3086         FCB     $C2
3087         FCC     'D'     ; 'DO'
3088         FCB     $CF
3089         FDB     THEN-7
3090 DO      FDB     DOCOL,COMPIL,XDO,HERE,THREE
3091         FDB     SEMIS
3092 *
3093 * ======>>  199  <<
3094         FCB     $C4
3095         FCC     'LOO'   ; 'LOOP'
3096         FCB     $D0
3097         FDB     DO-5
3098 LOOP    FDB     DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
3099         FDB     SEMIS
3100 *
3101 * ======>>  200  <<
3102         FCB     $C5
3103         FCC     '+LOO'  ; '+LOOP'
3104         FCB     $D0
3105         FDB     LOOP-7
3106 PLOOP   FDB     DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
3107         FDB     SEMIS
3108 *
3109 * ======>>  201  <<
3110         FCB     $C5
3111         FCC     'UNTI'  ; 'UNTIL' :     ( same as END )
3112         FCB     $CC
3113         FDB     PLOOP-8
3114 UNTIL   FDB     DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
3115         FDB     SEMIS
3116 *
3117 * ######>> screen 74 <<
3118 * ======>>  202  <<
3119         FCB     $C3
3120         FCC     'EN'    ; 'END'
3121         FCB     $C4
3122         FDB     UNTIL-8
3123 END     FDB     DOCOL,UNTIL
3124         FDB     SEMIS
3125 *
3126 * ======>>  203  <<
3127         FCB     $C5
3128         FCC     'AGAI'  ; 'AGAIN'
3129         FCB     $CE
3130         FDB     END-6
3131 AGAIN   FDB     DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
3132         FDB     SEMIS
3133 *
3134 * ======>>  204  <<
3135         FCB     $C6
3136         FCC     'REPEA' ; 'REPEAT'
3137         FCB     $D4
3138         FDB     AGAIN-8
3139 REPEAT  FDB     DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
3140         FDB     TWO,SUB,ENDIF
3141         FDB     SEMIS
3142 *
3143 * ======>>  205  <<
3144         FCB     $C2
3145         FCC     'I'     ; 'IF'
3146         FCB     $C6
3147         FDB     REPEAT-9
3148 IF      FDB     DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
3149         FDB     SEMIS
3150 *
3151 * ======>>  206  <<
3152         FCB     $C4
3153         FCC     'ELS'   ; 'ELSE'
3154         FCB     $C5
3155         FDB     IF-5
3156 ELSE    FDB     DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
3157         FDB     ZERO,COMMA,SWAP,TWO,ENDIF,TWO
3158         FDB     SEMIS
3159 *
3160 * ======>>  207  <<
3161         FCB     $C5
3162         FCC     'WHIL'  ; 'WHILE'
3163         FCB     $C5
3164         FDB     ELSE-7
3165 WHILE   FDB     DOCOL,IF,TWOP
3166         FDB     SEMIS
3167 *
3168 * ######>> screen 75 <<
3169 * ======>>  208  <<
3170         FCB     $86
3171         FCC     'SPACE' ; 'SPACES'
3172         FCB     $D3
3173         FDB     WHILE-8
3174 SPACES  FDB     DOCOL,ZERO,MAX,DDUP,ZBRAN
3175         FDB     SPACE3-*
3176         FDB     ZERO,XDO
3177 SPACE2  FDB     SPACE,XLOOP
3178         FDB     SPACE2-*
3179 SPACE3  FDB     SEMIS
3180 *
3181 * ======>>  209  <<
3182         FCB     $82
3183         FCC     '<'     ; '<#'
3184         FCB     $A3
3185         FDB     SPACES-9
3186 BDIGS   FDB     DOCOL,PAD,HLD,STORE
3187         FDB     SEMIS
3188 *
3189 * ======>>  210  <<
3190         FCB     $82
3191         FCC     '#'     ; '#>'
3192         FCB     $BE
3193         FDB     BDIGS-5
3194 EDIGS   FDB     DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
3195         FDB     SEMIS
3196 *
3197 * ======>>  211  <<
3198         FCB     $84
3199         FCC     'SIG'   ; 'SIGN'
3200         FCB     $CE
3201         FDB     EDIGS-5
3202 SIGN    FDB     DOCOL,ROT,ZLESS,ZBRAN
3203         FDB     SIGN2-*
3204         FDB     CLITER
3205         FCC     "-"
3206         FDB     HOLD
3207 SIGN2   FDB     SEMIS
3208 *
3209 * ======>>  212  <<
3210         FCB     $81     #
3211         FCB     $A3
3212         FDB     SIGN-7
3213 DIG     FDB     DOCOL,BASE,AT,MSMOD,ROT,CLITER
3214         FCB     9
3215         FDB     OVER,LESS,ZBRAN
3216         FDB     DIG2-*
3217         FDB     CLITER
3218         FCB     7
3219         FDB     PLUS
3220 DIG2    FDB     CLITER
3221         FCC     "0"     ascii zero
3222         FDB     PLUS,HOLD
3223         FDB     SEMIS
3224 *
3225 * ======>>  213  <<
3226         FCB     $82
3227         FCC     '#'     ; '#S'
3228         FCB     $D3
3229         FDB     DIG-4
3230 DIGS    FDB     DOCOL
3231 DIGS2   FDB     DIG,OVER,OVER,OR,ZEQU,ZBRAN
3232         FDB     DIGS2-*
3233         FDB     SEMIS
3234 *
3235 * ######>> screen 76 <<
3236 * ======>>  214  <<
3237         FCB     $82
3238         FCC     '.'     ; '.R'
3239         FCB     $D2
3240         FDB     DIGS-5
3241 DOTR    FDB     DOCOL,TOR,STOD,FROMR,DDOTR
3242         FDB     SEMIS
3243 *
3244 * ======>>  215  <<
3245         FCB     $83
3246         FCC     'D.'    ; 'D.R'
3247         FCB     $D2
3248         FDB     DOTR-5
3249 DDOTR   FDB     DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
3250         FDB     EDIGS,FROMR,OVER,SUB,SPACES,TYPE
3251         FDB     SEMIS
3252 *
3253 * ======>>  216  <<
3254         FCB     $82
3255         FCC     'D'     ; 'D.'
3256         FCB     $AE
3257         FDB     DDOTR-6
3258 DDOT    FDB     DOCOL,ZERO,DDOTR,SPACE
3259         FDB     SEMIS
3260 *
3261 * ======>>  217  <<
3262         FCB     $81     .
3263         FCB     $AE
3264         FDB     DDOT-5
3265 DOT     FDB     DOCOL,STOD,DDOT
3266         FDB     SEMIS
3267 *
3268 * ======>>  218  <<
3269         FCB     $81     ?
3270         FCB     $BF
3271         FDB     DOT-4
3272 QUEST   FDB     DOCOL,AT,DOT
3273         FDB     SEMIS
3274 *
3275 * ######>> screen 77 <<
3276 * ======>>  219  <<
3277         FCB     $84
3278         FCC     'LIS'   ; 'LIST'
3279         FCB     $D4
3280         FDB     QUEST-4
3281 LIST    FDB     DOCOL,DECIM,CR,DUP,SCR,STORE,PDOTQ
3282         FCB     6
3283         FCC     "SCR # "
3284         FDB     DOT,CLITER
3285         FCB     $10
3286         FDB     ZERO,XDO
3287 LIST2   FDB     CR,I,THREE
3288         FDB     DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
3289         FDB     LIST2-*
3290         FDB     CR
3291         FDB     SEMIS
3292 *
3293 * ======>>  220  <<
3294         FCB     $85
3295         FCC     'INDE'  ; 'INDEX'
3296         FCB     $D8
3297         FDB     LIST-7
3298 INDEX   FDB     DOCOL,CR,ONEP,SWAP,XDO
3299 INDEX2  FDB     CR,I,THREE
3300         FDB     DOTR,SPACE,ZERO,I,DLINE
3301         FDB     QTERM,ZBRAN
3302         FDB     INDEX3-*
3303         FDB     LEAVE
3304 INDEX3  FDB     XLOOP
3305         FDB     INDEX2-*
3306         FDB     SEMIS
3307 *
3308 * ======>>  221  <<
3309         FCB     $85
3310         FCC     'TRIA'  ; 'TRIAD'
3311         FCB     $C4
3312         FDB     INDEX-8
3313 TRIAD   FDB     DOCOL,THREE,SLASH,THREE,STAR
3314         FDB     THREE,OVER,PLUS,SWAP,XDO
3315 TRIAD2  FDB     CR,I
3316         FDB     LIST,QTERM,ZBRAN
3317         FDB     TRIAD3-*
3318         FDB     LEAVE
3319 TRIAD3  FDB     XLOOP
3320         FDB     TRIAD2-*
3321         FDB     CR,CLITER
3322         FCB     $0F
3323         FDB     MESS,CR
3324         FDB     SEMIS
3325 *
3326 * ######>> screen 78 <<
3327 * ======>>  222  <<
3328         FCB     $85
3329         FCC     'VLIS'  ; 'VLIST'
3330         FCB     $D4
3331         FDB     TRIAD-8
3332 VLIST   FDB     DOCOL,CLITER
3333         FCB     $80
3334         FDB     OUT,STORE,CONTXT,AT,AT
3335 VLIST1  FDB     OUT,AT,COLUMS,AT,CLITER
3336         FCB     32
3337         FDB     SUB,GREAT,ZBRAN
3338         FDB     VLIST2-*
3339         FDB     CR,ZERO,OUT,STORE
3340 VLIST2  FDB     DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
3341         FDB     DUP,ZEQU,QTERM,OR,ZBRAN
3342         FDB     VLIST1-*
3343         FDB     DROP
3344         FDB     SEMIS
3345 *
3346 * ======>>  XX  <<
3347         FCB     $84
3348         FCC     'NOO'   ; 'NOOP'
3349         FCB     $D0
3350         FDB     VLIST-8
3351 NOOP    FDB     NEXT    a useful no-op
3352 ZZZZ    FDB     0,0,0,0,0,0,0,0 end of rom program
3353
3354
3355
3356
3357
3358
3359
3360         PAGE
3361         OPT     L
3362         END