fig-forth-auto6809.asm

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