fig6800to6809dumb.asm

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