fig6800to6809dumb.asm

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