fig-forth-auto6809opt.asm

   1         OPT PRT
   2
   3 * fig-FORTH FOR 6809
   4 * ASSEMBLY SOURCE LISTING
   5
   6 * RELEASE 0
   7 * JAN 2019
   8 * WITH COMPILER SECURITY
   9 * AND VARIABLE LENGTH NAMES
  10 *
  11 * Adapted by Joel Matthew Rees
  12 * from fig-FORTH for 6800 by Dave Lion, et. al.
  13
  14 * This free/libre/open source publication is provided
  15 * through the courtesy of:
  16 * FORTH
  17 * INTEREST
  18 * GROUP
  19 * fig
  20 * and other interested parties.
  21
  22 * Ancient address:
  23 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
  24 * URL: http://www.forth.org
  25 * Further distribution must include this notice.
  26         PAGE
  27         NAM     Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
  28         OPT     NOG,PAG
  29 * filename fig-forth-auto6809opt.asm
  30 * === FORTH-6809 {date} {time}
  31
  32
  33 * Permission is hereby granted, free of charge, to any person obtaining a copy
  34 * of this software and associated documentation files (the "Software"), to deal
  35 * in the Software without restriction, including without limitation the rights
  36 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  37 * copies of the Software, and to permit persons to whom the Software is
  38 * furnished to do so, subject to the following conditions:
  39 *
  40 * The above copyright notice and this permission notice shall be included in
  41 * all copies or substantial portions of the Software.
  42
  43 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  44 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  45 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  46 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  47 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  48 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  49 * THE SOFTWARE.
  50 *
  51 * "Associated documentation" for this declaration of license
  52 * shall be interpreted to include only the comments in this file,
  53 * or, if the code is split into multiple files,
  54 * all files containing the complete source.
  55 *
  56 * This is the MIT model license, as published by the Open Source Consortium,
  57 * with associated documentation defined.
  58 * It was chosen to reflect the spirit of the original
  59 * terms of use, which used archaic legal terminology.
  60 *
  61
  62 * Authors of the 6800 model:
  63 * === Primary: Dave Lion,
  64 * ===  with help from
  65 * === Bob Smith,
  66 * === LaFarr Stuart,
  67 * === The Forth Interest Group
  68 * === PO Box 1105
  69 * === San Carlos, CA 94070
  70 * ===  and
  71 * === Unbounded Computing
  72 * === 1134-K Aster Ave.
  73 * === Sunnyvale, CA 94086
  74 *
  75 NATWID  EQU     2       ; bytes per natural integer/pointer
  76 *  The original version was developed on an AMI EVK 300 PROTO
  77 *  system using an ACIA for the I/O.
  78 *  This version is developed targeting the Tandy Color Computer.
  79
  80 *  All terminal 1/0
  81 *  is done in three subroutines:
  82 *   PEMIT  ( word # 182 )
  83 *   PKEY   (        183 )
  84 *   PQTERM (        184 )
  85 *
  86 *  The FORTH words for disc related I/O follow the model
  87 *  of the FORTH Interest Group, but have not yet been
  88 *  tested using a real disc.
  89 *
  90 *  Addresses in the 6800 implementation reflect the fact that,
  91 *  on the development system, it was convenient to
  92 *  write-protect memory at hex 1000, and leave the first
  93 *  4K bytes write-enabled. As a consequence, code from
  94 *  location $1000 to lable ZZZZ could be put in ROM.
  95 *  Minor deviations from the model were made in the
  96 *  initialization and words ?STACK and FORGET
  97 *  in order to do this.
  98 *  Those deviations will be altered in this
  99 *  implementation for the 6809 -- Color Computer.
 100 *
 101
 102 *
 103 MEMT32  EQU     $7FFF   absolute end of all ram
 104 MEMT16  EQU     $3FFF
 105 MEMTOP  EQU     MEMT16  ; tentative guess
 106 ACIAC   EQU     $FBCE   the ACIA control address and
 107 ACIAD   EQU     ACIAC+1 data address for PROTO
 108         PAGE
 109 *  MEMORY MAP for this 16K|32K system:
 110 *  ( delineated so that systems with 4k byte write-
 111 *   protected segments can write protect FORTH )
 112 *
 113 * addr.         contents                pointer init by
 114 * ****  ******************************* ******* ******
 115 *       2nd through 4th per-user tables
 116 * 4000|7D00
 117 USERSZ  EQU     256     ; (Addressable by DP)
 118 USER16  EQU     1       ; We can change these for ROMPACK or 64K.
 119 USER32  EQU     4
 120 USERCT  EQU     USER16
 121 IUP16   EQU     MEMT16+1-USER16*USERSZ
 122 IUP32   EQU     MEMT32+1-USER32*USERSZ
 123 IUP     EQU     IUP16
 124 IUPDP   EQU     IUP/256
 125 *       user tables of variables
 126 *       registers & pointers for the virtual machine
 127 *       scratch area used by various words
 128 * 3F00|7C00                             <== UP (DICTPT)
 129 * 3EFF|7BFF                                     HI
 130 *       substitute for disc mass memory
 131 RAMSCR  EQU     3
 132 SCRSZ   EQU     1024
 133 * 3300|7000                                     LO,MEMEND
 134 RAMD16  EQU     IUP16-RAMSCR*SCRSZ
 135 RAMD32  EQU     IUP32-RAMSCR*SCRSZ
 136 RAMDSK  EQU     RAMD16
 137 MEME16  EQU     RAMD16
 138 MEME32  EQU     RAMD32
 139 MEMEND  EQU     MEME16
 140 * 32FF|6FFF
 141 *       4 buffer sectors of VIRTUAL MEMORY
 142 NBLK    EQU     4 ; # of disc buffer blocks for virtual memory
 143 * Should NBLK be SCRSZ/SECTSZ?
 144 *  each block is SECTSZ+SECTRL bytes in size,
 145 *  holding SECTSZ characters
 146 SECTSZ  EQU     256
 147 SECTRL  EQU     8
 148 BUFSZ   EQU     (SECTSZ+SECTRL)*NBLK
 149 * 2EE0|6BE0                                     FIRST
 150 BUFB16  EQU     MEME16-BUFSZ
 151 BUFB32  EQU     MEME32-BUFSZ
 152 BUFBAS  EQU     BUFB16
 153 * "end" of "usable ram" -- in 16K
 154 * 2EE0|6BE0                             <== RP  RINIT
 155 IRP16   EQU     BUFB16
 156 IRP32   EQU     BUFB32
 157 IRP     EQU     IRP16
 158 *       RETURN STACK
 159 *       (64|112 levels nesting)
 160 RSTK16  EQU     128
 161 RSTK32  EQU     224
 162 * (2E60|6B00)
 163 SFTB16  EQU     IRP16-RSTK16
 164 SFTB32  EQU     IRP32-RSTK32
 165 SFTBND  EQU     SFTB16
 166 *       INPUT LINE BUFFER
 167 *       holds up to 256 characters
 168 *       and is scanned upward by IN
 169 *       starting at TIB
 170 TIBSZ   EQU     256
 171 * 2D60|6A00
 172 ITIB16  EQU     SFTB16-TIBSZ
 173 ITIB32  EQU     SFTB32-TIBSZ
 174 ITIB    EQU     ITIB16
 175 * 2D60|6A00                             <== IN  TIB
 176 ISP16   EQU     ITIB16
 177 ISP32   EQU     ITIB32
 178 ISP     EQU     ISP16
 179 * 2D60|6A00                             <== SP  SP0,SINIT
 180 *       DATA STACK
 181 *    |  grows downward from 2A60|6A00
 182 *    v
 183 *  - -
 184 *    |
 185 *    I  DICTIONARY grows upward
 186 *
 187 * ????  end of ram-dictionary.          <== DICTPT      DPINIT
 188 *       "TASK"
 189 *
 190 * ????  "FORTH" ( a word )              <=, <== CONTEXT
 191 *                                       `==== CURRENT
 192 *       start of ram-dictionary.
 193 *
 194 * >>>>>> memory from here up must be in RAM area <<<<<<
 195 *
 196 * ????
 197 *       6k of romable "FORTH"           <== IP  ABORT
 198 *                                       <== W
 199 *       the VIRTUAL FORTH MACHINE
 200 *
 201 * 1208  initialization tables
 202 * 1204 <<< WARM START ENTRY >>>
 203 * 1200 <<< COLD START ENTRY >>>
 204 * 1200  lowest address used by FORTH
 205 *
 206 CODEBG  EQU $1200
 207 *
 208 * >>>>>> memory from here down left alone <<<<<<
 209 * >>>>>> so we can safely call ROM routines <<<<<<
 210 *
 211 * 0000
 212         PAGE
 213 ***
 214 *
 215 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
 216 *
 217 * IP (hardware Y) points to the current instruction ( pre-increment mode )
 218 * RP (hardware S) points to last return address pushedin return stack
 219 * SP (hardware U) points to last byte pushed in data stack
 220 *
 221 * Y must be IP when NEXT is entered (if using the inner loop).
 222 *
 223 *       When A and B hold one 16 bit FORTH data word,
 224 *       A contains the high byte, B, the low byte.
 225 *
 226 * UP (hardware DP) is the base of per-task ("user") variables.
 227 * (Be careful of the stray semantics of "user".)
 228 *
 229 * W (hardware X) is the pointer to the "code field" address of native CPU
 230 * machine code to be executed for the definition of the dictionary word
 231 * to be executed/currently executing.
 232 * The following natural integer (word) begins any "parameter section"
 233 * (body) -- similar to a "this" pointer, but not the same.
 234 * It may be native CPU machine code, or it may be a global variable,
 235 * or it may be a list of Forth definition words (addresses).
 236 *
 237 * ======
 238 * This implementation uses the native subroutine architecture
 239 * rather than a postponed-push call that the 6800 model VM uses
 240 * to save code and time in leaf routines.
 241 *
 242 * This should allow directly calling many of the Forth words
 243 * from assembly language code.
 244 * (Be aware of the need for a valid W in some cases.)
 245 * It won't allow mixing assembly language directly into Forth word lists.
 246 * ======
 247 *
 248 * boolean flags:
 249 * 0 is false, anything else is true.
 250 * Most places in this model that set a boolean flag set true as 1.
 251 * This is in contrast to many models that set a boolean flag as -1.
 252 *
 253 ***
 254
 255         PAGE
 256 *       This system is shown with one user (task),
 257 *       but additional users (tasks) may be added
 258 *       by allocating additional user tables:
 259 *
 260         ORG     IUP
 261 UBASE   RMB     USERSZ
 262 UBASEX  RMB     USERSZ data table for extra users
 263 *
 264 *       Some of this stuff gets initialized during
 265 *       COLD start and WARM start:
 266 *       [ names correspond to FORTH words of similar (no X) name ]
 267 *
 268         ORG     IUP
 269 UORIG   EQU     *
 270 *               A few useful VM variables
 271 * Will be removed when they are no longer needed.
 272 * All are replaced by 6809 registers.
 273
 274 N       RMB     10      used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
 275 *                               SP@,SWAP,DOES>,COLD
 276
 277
 278 *       These locations are used by the TRACE routine :
 279
 280 TRLIM   RMB     1       the count for tracing without user intervention
 281 TRACEM  RMB     1       non-zero = trace mode
 282 BRKPT   RMB     2       the breakpoint address at which
 283 *                       the program will go into trace mode
 284 VECT    RMB     2       vector to machine code
 285 *       (only needed if the TRACE routine is resident)
 286
 287
 288 *       Registers used by the FORTH virtual machine:
 289 *       Starting at $OOFO:
 290
 291
 292 W       RMB     2       the instruction register points to 6800 code
 293 * This is not exactly accurate. Points to the definiton body,
 294 * which is native CPU machine code when it is native CPU machine code.
 295 IP      RMB     2       the instruction pointer points to pointer to 6800 code
 296 RP      RMB     2       the return stack pointer
 297 UP      RMB     2       the pointer to base of current user's 'USER' table
 298 *               ( altered during multi-tasking )
 299 *
 300 *UORIG  RMB     6       3 reserved variables
 301 XSPZER  RMB     2       initial top of data stack for this user
 302 XRZERO  RMB     2       initial top of return stack
 303 XTIB    RMB     2       start of terminal input buffer
 304 XWIDTH  RMB     2       name field width
 305 XWARN   RMB     2       warning message mode (0 = no disc)
 306 XFENCE  RMB     2       fence for FORGET
 307 XDICTP  RMB     2       dictionary pointer
 308 XVOCL   RMB     2       vocabulary linking
 309 XBLK    RMB     2       disc block being accessed
 310 XIN     RMB     2       scan pointer into the block
 311 XOUT    RMB     2       cursor position
 312 XSCR    RMB     2       disc screen being accessed ( O=terminal )
 313 XOFSET  RMB     2       disc sector offset for multi-disc
 314 XCONT   RMB     2       last word in primary search vocabulary
 315 XCURR   RMB     2       last word in extensible vocabulary
 316 XSTATE  RMB     2       flag for 'interpret' or 'compile' modes
 317 XBASE   RMB     2       number base for I/O numeric conversion
 318 XDPL    RMB     2       decimal point place
 319 XFLD    RMB     2
 320 XCSP    RMB     2       current stack position, for compile checks
 321 XRNUM   RMB     2
 322 XHLD    RMB     2
 323 XDELAY  RMB     2       carriage return delay count
 324 XCOLUM  RMB     2       carriage width
 325 IOSTAT  RMB     2       last acia status from write/read
 326         RMB     2       ( 4 spares! )
 327         RMB     2
 328         RMB     2
 329         RMB     2
 330
 331
 332
 333
 334 *
 335 *
 336 *   end of user table, start of common system variables
 337 *
 338 *
 339 *
 340 XUSE    RMB     2
 341 XPREV   RMB     2
 342         RMB     4       ( spares )
 343
 344         PAGE
 345 *    The FORTH program ( address $1200 to about $27FF ) will be written
 346 *    so that it can be in a ROM, or write-protected if desired,
 347 * but right now we're just getting it running.
 348         ORG     CODEBG
 349
 350 * ######>> screen 3 <<
 351 *
 352 ***************************
 353 **  C O L D   E N T R Y  **
 354 ***************************
 355 ORIG    NOP
 356         JMP     CENT
 357 ***************************
 358 **  W A R M   E N T R Y  **
 359 ***************************
 360         NOP
 361         JMP     WENT    warm-start code, keeps current dictionary intact
 362
 363         SETDP   IUPDP
 364
 365 *
 366 ******* startup parmeters **************************
 367 *
 368         FDB     $6809,0000      cpu & revision
 369         FDB     0       topmost word in FORTH vocabulary
 370 BACKSP  FDB     $7F     backspace character for editing
 371 UPINIT  FDB     UORIG   initial user area
 372 * UPINIT        FDB     UORIG   initial user area
 373 SINIT   FDB     ISP     ; initial top of data stack
 374 * SINIT FDB     ORIG-$D0        initial top of data stack
 375 RINIT   FDB     IRP     ; initial top of return stack
 376 * RINIT FDB     ORIG-2  initial top of return stack
 377         FDB     ITIB    ; terminal input buffer
 378 *       FDB     ORIG-$D0        terminal input buffer
 379         FDB     31      initial name field width
 380         FDB     0       initial warning mode (0 = no disc)
 381 FENCIN  FDB     REND    initial fence
 382 DPINIT  FDB     REND    cold start value for DICTPT
 383 VOCINT  FDB     FORTH+8
 384 COLINT  FDB     132     initial terminal carriage width
 385 DELINT  FDB     4       initial carriage return delay
 386 ****************************************************
 387 *
 388         PAGE
 389 *
 390 * ######>> screen 13 <<
 391 * These were of questionable use anyway,
 392 * kept here now to satisfy the assembler and show hints.
 393 * They're too much trouble to use with native subroutine call anyway.
 394 * PULABX        PULS A  ; 24 cycles until 'NEXT'
 395 *       PULS B  ;
 396 PULABX  PULU A,B        ; ?? cycles until 'NEXT'
 397 * STABX STA 0,X 16 cycles until 'NEXT'
 398 *       STB 1,X
 399 STABX   STD 0,X ; ?? cycles until 'NEXT'
 400         BRA     NEXT
 401 * GETX  LDA 0,X 18 cycles until 'NEXT'
 402 *       LDB 1,X
 403 GETX    LDD 0,X ?? cycles until 'NEXT'
 404 * PUSHBA        PSHS B  ; 8 cycles until 'NEXT'
 405 *       PSHS A  ;
 406 PUSHBA  PSHU A,B        ; ?? cycles until 'NEXT'
 407
 408
 409 *
 410 * "NEXT" takes ?? cycles if TRACE is removed,
 411 *
 412 * and ?? cycles if trace is present and NOT tracing.
 413 *
 414 * = = = = = = =   t h e   v i r t u a l   m a c h i n e   = = = = =
 415 *                                                                 =
 416 * NEXT itself might just completely go away.
 417 * About the only reason to keep it is to allowing executing a list
 418 * which allows a cheap TRACE routine.
 419 *
 420 * NEXT is a loop which implements the Forth VM.
 421 * It basically cycles through calling the code out of code lists,
 422 * one at a time.
 423 * Using a native CPU return for this uses a few extra cycles per call,
 424 * compared to simply jumping to each definition and jumping back
 425 * to the known beginning of the loop,
 426 * but the loop itself is really only there for convenience.
 427 *
 428 * This implementation uses the native subroutine call,
 429 * to break the wall between Forth code and non-Forth code.
 430 *
 431 * NEXT  LDX     IP
 432 *       LEAX 1,X        ;               pre-increment mode
 433 *       LEAX 1,X        ;
 434 *       STX     IP
 435 NEXT    ; IP is Y, push before using, pull before you come back here.
 436 *
 437 * NEXT2 LDX     0,X     get W which points to CFA of word to be done
 438 NEXT2   LDX     ,Y++    get W which points to CFA of word to be done
 439 * But NEXT2 is too much trouble to use with subroutine threading anyway.
 440 * NEXT3 STX     W
 441 NEXT3   ; W is X until you use X for something else. (TOS points back here.)
 442 * But NEXT3 is too much trouble to use with subroutine threading anyway.
 443 *       LDX     0,X     get VECT which points to executable code
 444 *                                                                 =
 445 * The next instruction could be patched to JMP TRACE              =
 446 * if a TRACE routine is available:                                =
 447 *                                                                 =
 448 *       JMP     0,X
 449         JSR     [,X]    ; Saving the postinc cycles,
 450 *                       ; but X must be bumped NATWID to the parameters.
 451         NOP
 452 *       JMP     TRACE   ( an alternate for the above )
 453 * In other words, with the call and the NOP,
 454 * there is room to patch the call with a JMP to your TRACE
 455 * routine, which you have to provide.
 456         BRA     NEXT
 457 *                                                                 =
 458 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
 459
 460
 461         PAGE
 462 *
 463 * ======>>  1  <<
 464 * ( --- n )
 465 * Pushes the following natural width integer from the instruction stream
 466 * as a literal, or immediate value.
 467 *
 468 *       FDB {OP}
 469 *       FDB {OP}
 470 *       FDB LIT
 471 *       FDB LITERAL-TO-BE-PUSHED
 472 *       FDB {OP}
 473 *
 474 * In native processor code, there should be a better way, use that instead.
 475 * More specifically, DO NOT CALL THIS from assembly language code.
 476 * (Note that there is no compile-only flag in the fig model.)
 477 *
 478 * See (FIND), or PFIND , for layout of the header format.
 479 *
 480         FCB     $83
 481         FCC     'LI'    ; 'LIT' :       NOTE: this is different from LITERAL
 482         FCB     $D4
 483         FDB     0       ; link of zero to terminate dictionary scan
 484 LIT     FDB     *+NATWID        ; Note also that it is meaningless in native code.
 485         LDD     ,Y++
 486         PSHU    A,B
 487         RTS
 488 *       LDX     IP
 489 *       LEAX 1,X        ;
 490 *       LEAX 1,X        ;
 491 *       STX     IP
 492 *       LDA 0,X
 493 *       LDB 1,X
 494 *       JMP     PUSHBA
 495 *
 496 * ######>> screen 14 <<
 497 * ======>>  2  <<
 498 * ( --- n )
 499 * Pushes the following byte from the instruction stream
 500 * as a literal, or immediate value.
 501 *
 502 *       FDB {OP}
 503 *       FDB {OP}
 504 *       FDB LIT8
 505 *       FCB LITERAL-TO-BE-PUSHED
 506 *       FDB {OP}
 507 *
 508 * If this is kept, it should have a header for TRACE to read.
 509 * If the data bus is wider than a byte, you don't want to do this.
 510 * Byte shaving like this is often counter-productive anyway.
 511 * Changing the name to LIT8, hoping that will be more understandable.
 512 * Also, see comments for LIT.
 513 * (Note that there is no compile-only flag in the fig model.)
 514         FCB     $84
 515         FCC     'LIT'   ; 'LIT8' :      NOTE: this is different from LITERAL
 516         FCB     $B8
 517         FDB     LIT-6
 518 LIT8    FDB     *+NATWID         (this was an invisible word, with no header)
 519         LDB     ,Y+     ; This also is meaningless in native code.
 520         CLRA
 521         PSHU    A,B
 522         RTS
 523 *       LDX     IP
 524 *       LEAX 1,X        ;
 525 *       STX     IP
 526 *       CLRA    ;
 527 *       LDB 1,X
 528 *       JMP     PUSHBA
 529 *
 530 * ======>>  3  <<
 531 * ( adr --- )
 532 * Jump to address on stack.  Used by the "outer" interpreter to
 533 * interactively invoke routines.
 534 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
 535         FCB     $87
 536         FCC     'EXECUT'        ; 'EXECUTE'
 537         FCB     $C5
 538         FDB     LIT-7
 539 EXEC    FDB     *+NATWID
 540         PULU    X       ; Gotta have W anyway, just in case.
 541         JMP     [,X]    ; Tail return.
 542 *       TFR S,X ; TSX :
 543 *       LDX     0,X     get code field address (CFA)
 544 *       LEAS 1,S        ;               pop stack
 545 *       LEAS 1,S        ;
 546 *       JMP     NEXT3
 547 *
 548 * ######>> screen 15 <<
 549 * ======>>  4  <<
 550 * ( --- )                                                 C
 551 * Add the following word from the instruction stream to the
 552 * instruction pointer (Y++).  Causes a program branch in Forth code stream.
 553 *
 554 * In native processor code, there should be a better way, use that instead.
 555 * More specifically, DO NOT CALL THIS from assembly language code.
 556 * This is only for Forth code stream.
 557 * Also, see comments for LIT.
 558         FCB     $86
 559         FCC     'BRANC' ; 'BRANCH'
 560         FCB     $C8
 561         FDB     EXEC-10
 562 BRAN    FDB     ZBYES   ; Go steal code in ZBRANCH
 563
 564 * Moving code around to optimize the branch taking case in 0BRANCH.
 565 ZBNO    LEAY    NATWID,Y ;      No branch.
 566         RTS
 567 * ======>>  5  <<
 568 * ( f --- )                                               C
 569 * BRANCH if flag is zero.
 570 *
 571 * In native processor code, there should be a better way, use that instead.
 572 * More specifically, DO NOT CALL THIS from assembly language code.
 573 * This is only for Forth code stream.
 574 * Also, see comments for LIT.
 575         FCB     $87
 576         FCC     '0BRANC'        ; '0BRANCH'
 577         FCB     $C8
 578         FDB     BRAN-9
 579 ZBRAN   FDB     *+NATWID
 580         LDD     ,U++
 581         BNE     ZBNO
 582 ZBYES   LDD     ,Y++
 583         LEAY    D,Y     ; IP is postinc
 584         RTS
 585 *       PULS A  ;
 586 *       PULS B  ;
 587 *       PSHS B  ; ** emulating ABA:
 588 *       ADDA ,S+        ;
 589 *       BNE     ZBNO
 590 *       BCS     ZBNO
 591 * ZBYES LDX     IP      Note: code is shared with BRANCH, (+LOOP), (LOOP)
 592 *       LDB 3,X
 593 *       LDA 2,X
 594 *       ADDB IP+1
 595 *       ADCA IP
 596 *       STB IP+1
 597 *       STA IP
 598 *       JMP     NEXT
 599 * ZBNO  LDX     IP      no branch. This code is shared with (+LOOP), (LOOP).
 600 *       LEAX 1,X        ;               jump over branch delta
 601 *       LEAX 1,X        ;
 602 *       STX     IP
 603 *       JMP     NEXT
 604 *
 605 * ######>> screen 16 <<
 606 * ======>>  6  <<
 607 * ( --- )         ( limit index *** limit index+1)        C
 608 *                 ( limit index *** )
 609 * Counting loop primitive.  The counter and limit are the top two
 610 * words on the return stack.  If the updated index/counter does
 611 * not exceed the limit, a branch occurs.  If it does, the branch
 612 * does not occur, and the index and limit are dropped from the
 613 * return stack.
 614 *
 615 * In native processor code, there should be a better way, use that instead.
 616 * More specifically, DO NOT CALL THIS from assembly language code.
 617 * This is only for Forth code stream.
 618 * Also, see comments for LIT.
 619         FCB     $86
 620         FCC     '(LOOP' ; '(LOOP)'
 621         FCB     $A9
 622         FDB     ZBRAN-10
 623 XLOOP   FDB     *+NATWID
 624         LDD     #1      ; Borrowing from BIF-6809.
 625 XLOOPA  ADDD    2,S     ; Dodge the return address.
 626         STD     2,S
 627         SUBD    4,S
 628         BLT     ZBYES   ; signed
 629 XLOOPN  LEAY    2,Y
 630         LDX     ,S      ; synthetic return
 631         LEAS    6,S     ; Clean up the index and limit.
 632         JMP     ,X
 633 *       CLRA    ;
 634 *       LDB #1  get set to increment counter by 1 (Clears N.)
 635 *       BRA     XPLOP2  go steal other guy's code!
 636 *
 637 * ======>>  7  <<
 638 * ( n --- )       ( limit index *** limit index+n )       C
 639 *                 ( limit index *** )
 640 * Loop with a variable increment.  Terminates when the index
 641 * crosses the boundary from one below the limit to the limit.  A
 642 * positive n will cause termination if the result index equals the
 643 * limit.  A negative n must cause the index to become less than
 644 * the limit to cause loop termination.
 645 *
 646 * Note that the end conditions are not symmetric around zero.
 647 *
 648 * In native processor code, there should be a better way, use that instead.
 649 * More specifically, DO NOT CALL THIS from assembly language code.
 650 * This is only for Forth code stream.
 651 * Also, see comments for LIT.
 652         FCB     $87
 653         FCC     '(+LOOP'        ; '(+LOOP)'
 654         FCB     $A9
 655         FDB     XLOOP-9
 656 XPLOOP  FDB     *+NATWID        ; Borrowing from BIF-6809.
 657         LDD     ,U++            ; inc val
 658         BPL     XLOOPA          ; Steal plain loop code for forward count.
 659         ADDD    2,S             ; Dodge the return address
 660         STD     2,S
 661         SUBD    4,S
 662         BGT     ZBYES           ; signed
 663         BRA     XLOOPN          ; This path is less time-sensitive.
 664 *
 665 * This should work, but I want to use tested code.
 666 *       PULU    A,B     ; Get the increment.
 667 * XPLOP2        PULS    X       ; Pre-clear the return stack.
 668 *       PSHU    A       ; Save the direction in high bit.
 669 *       ADDD    ,S      ; Count.
 670 *       STD     ,S      ; Update.
 671 *       SUBD    NATWID,S        ; Check limit.
 672 **
 673 ** I think this should work:
 674 *       EORA    ,U+     ; dir < 0 and (count - limit) >= 0
 675 *       BPL     XPLONO  ; or dir >= 0 and (count - limit) < 0
 676 *       LDD     ,Y++
 677 *       LEAY    D,Y     ; IP is postinc
 678 *       JMP     ,X
 679 * XPLONO        LEAS    2*NATWID,S
 680 *       JMP     ,X      ; synthetic return
 681 *
 682 * This definitely should work:
 683 *       TST     ,U+     ; Get the sign
 684 *       BPL     XPLOF   ;
 685 *       CMPD    NATWID,S
 686 *       BMI     XPLONO
 687 * XPLOYE        LDD     ,Y++
 688 *       LEAY    D,Y     ; IP is postinc
 689 *       JMP     ,X
 690 * XPLOF CMPD    NATWID,S
 691 *       BMI     XPLOYE
 692 * XPLONO        LEAS    2*NATWID,S
 693 *       JMP     ,X      ; synthetic return
 694 *
 695 * 6800 Probably could have used the exclusive-or method, too.:
 696 *       PULS A  ; get increment
 697 *       PULS B  ;
 698 * XPLOP2        TSTA    ;
 699 *       BPL     XPLOF   forward looping
 700 *       BSR     XPLOPS
 701 *       ORCC #$01       ; SEC :
 702 *       SBCB 5,X
 703 *       SBCA 4,X
 704 *       BPL     ZBYES
 705 *       BRA     XPLONO  fall through
 706 *
 707 * the subroutine :
 708 * XPLOPS        LDX     RP
 709 *       ADDB 3,X        add it to counter
 710 *       ADCA 2,X
 711 *       STB 3,X store new counter value
 712 *       STA 2,X
 713 *       RTS
 714 *
 715 * XPLOF BSR     XPLOPS
 716 *       SUBB 5,X
 717 *       SBCA 4,X
 718 *       BMI     ZBYES
 719 *
 720 * XPLONO        LEAX 1,X        ;               done, don't branch back
 721 *       LEAX 1,X        ;
 722 *       LEAX 1,X        ;
 723 *       LEAX 1,X        ;
 724 *       STX     RP
 725 *       BRA     ZBNO    use ZBRAN to skip over unused delta
 726 *
 727 * ######>> screen 17 <<
 728 * ======>>  8  <<
 729 * ( limit index --- )     ( *** limit index )
 730 * Move the loop parameters to the return stack.  Synonym for D>R.
 731         FCB     $84
 732         FCC     '(DO'   ; '(DO)'
 733         FCB     $A9
 734         FDB     XPLOOP-10
 735 XDO     FDB     *+NATWID        This is the RUNTIME DO, not the COMPILING DO
 736         LDX     ,S      ; Save the return address.
 737         PULU    A,B
 738         PSHS    A,B
 739         PULU    A,B     ; Maintain order.
 740         STD     NATWID,S
 741         JMP     ,X      ; synthetic return
 742 *
 743 *       LDX     RP
 744 *       LEAX -1,X       ;
 745 *       LEAX -1,X       ;
 746 *       LEAX -1,X       ;
 747 *       LEAX -1,X       ;
 748 *       STX     RP
 749 *       PULS A  ;
 750 *       PULS B  ;
 751 *       STA 2,X
 752 *       STB 3,X
 753 *       PULS A  ;
 754 *       PULS B  ;
 755 *       STA 4,X
 756 *       STB 5,X
 757 *       JMP     NEXT
 758 *
 759 * ======>>  9  <<
 760 * ( --- index )           ( limit index *** limit index )
 761 * Copy the loop index from the return stack.  Synonym for R.
 762         FCB     $81     I
 763         FCB     $C9
 764         FDB     XDO-7
 765 I       FDB     *+NATWID
 766         LDD     NATWID,S        ; Dodge return address.
 767         PSHU    A,B
 768         RTS
 769 *       LDX     RP
 770 *       LEAX 1,X        ;
 771 *       LEAX 1,X        ;
 772 *       JMP     GETX
 773 *
 774 * ######>> screen 18 <<
 775 * ======>>  10  <<
 776 * ( c base --- false )
 777 * ( c base --- n true )
 778 * Translate C in base, yielding a translation valid flag.  If the
 779 * translation is not valid in the specified base, only the false
 780 * flag is returned.
 781         FCB     $85
 782         FCC     'DIGI'  ; 'DIGIT'
 783         FCB     $D4
 784         FDB     I-4
 785 DIGIT   FDB     *+NATWID        NOTE: legal input range is 0-9, A-Z
 786         LDD     2,U     ; Check the whole thing.
 787         SUBD    #$30    ; ascii zero
 788         BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
 789         CMPD    #$A
 790         BMI     DIGIT0  IF '9' OR LESS
 791         CMPD    #$11
 792         BMI     DIGIT2  if less than 'A'
 793         CMPD    #$2B
 794         BPL     DIGIT2  if greater than 'Z'
 795         SUBD    #7      translate 'A' thru 'F'
 796 DIGIT0  CMPD    ,U      ; Check the base.
 797         BPL     DIGIT2  if not less than the base
 798         STD     2,U     ; Store converted digit. (High byte known zero.)
 799         LDD     #1      ; set valid flag
 800 DIGIT1  STD     ,U      ; store the flag
 801         RTS     NEXT
 802 DIGIT2  LDD     #0      ; set not valid flag
 803         LEAU    2,U     ; pop base
 804         BRA     DIGIT1
 805 *       TFR S,X ; TSX :
 806 *       LDA 3,X
 807 *       SUBA #$30       ascii zero
 808 *       BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
 809 *       CMPA #$A
 810 *       BMI     DIGIT0  IF '9' OR LESS
 811 *       CMPA #$11
 812 *       BMI     DIGIT2  if less than 'A'
 813 *       CMPA #$2B
 814 *       BPL     DIGIT2  if greater than 'Z'
 815 *       SUBA #7 translate 'A' thru 'F'
 816 * DIGIT0        CMPA 1,X
 817 *       BPL     DIGIT2  if not less than the base
 818 *       LDB #1  set flag
 819 *       STA 3,X store digit
 820 * DIGIT1        STB 1,X store the flag
 821 *       JMP     NEXT
 822 * DIGIT2        CLRB    ;
 823 *       LEAS 1,S        ;
 824 *       LEAS 1,S        ;       pop bottom number
 825 *       TFR S,X ; TSX :
 826 *       STB 0,X make sure both bytes are 00
 827 *       BRA     DIGIT1
 828 *
 829 * ######>> screen 19 <<
 830 *
 831 * The word definition format in the dictionary:
 832 *
 833 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
 834 *
 835 * NFA (name field address):
 836 * char-count + $80      Length of symbol name, flagged with high bit set.
 837 * char 1                Characters of symbol name.
 838 * char 2
 839 * ...
 840 * char n  + $80      symbol termination flag (char set < 128 code points)
 841 * LFA (link field address):
 842 * link high byte \___pointer to previous word in list
 843 * link low  byte /   -- Combined allocation/dictionary list. --
 844 * CFA (code field address):
 845 * CFA  high byte \___pointer to native CPU machine code
 846 * CFA  low  byte /   -- Consider this the characteristic code. --
 847 * PFA (parameter field address):
 848 * parameter fields   -- Machine code for low-level native machine CPU code,
 849 *    "                  instruction list for high-level Forth code,
 850 *    "                  constant data for constants, pointers to per task variables,
 851 *    "                  space for variables, for global variables, etc.
 852 *
 853 * In the case of native CPU machine code, the address at CFA will be PFA.
 854
 855 * Definition attributes:
 856 FIMMED  EQU     $40     ; Immediate word flag.
 857 FSMUDG  EQU     $20     ; Smudged => definition not ready.
 858 CTMASK  EQU     ($FF&(^($80|FIMMED)))   ; For unmasking the length byte.
 859 *
 860 * But we really want more:
 861 * FCOMPI        EQU     $10     ; Compile-time-only.
 862 * FASSEM        EQU     $08     ; Assembly-language code only.
 863 * F4THLV        EQU     $04     ; Must not be called from assembly language code.
 864 * These would require some significant adjustments to the model.
 865 * We also want to put the low-level VM stuff in its own vocabulary.
 866 *
 867 * ======>>  11  <<
 868 * (FIND)  ( name vocptr --- locptr length true )
 869 *         ( name vocptr --- false )
 870 * Search vocabulary for a symbol called name.
 871 * name is a pointer to a high-bit bracket string with length head.
 872 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
 873 * in the vocabulary to be searched.
 874 * HIDDEN (smudged) definitions are lexically less than their name strings.
 875         FCB     $86
 876         FCC     '(FIND' ; '(FIND)'
 877         FCB     $A9
 878         FDB     DIGIT-8
 879 PFIND   FDB     *+NATWID
 880         PSHS    Y       ; Have to track two pointers.
 881 * Use the stack and registers instead of temp area N.
 882 PA0     EQU     2       ; pointer to the length byte of name being searched against
 883 PD      EQU     0       ; pointer to NFA of dict word being checked
 884 *
 885         LDX     PD,U    ; Start in on the vocabulary (NFA).
 886 PFNDLP  LDY     PA0,U   ; Point to the name to check against.
 887         LDB     ,X+     ; get dict name length byte
 888         TFR     B,A     ; Save it in case it matches.
 889         ANDB    #CTMASK
 890         CMPB    ,Y+     ; Compare lengths
 891         BNE     PFNDUN
 892 PFNDBR  LDB     ,X+
 893         TSTB    ;       ; Is high bit of character in dictionary entry set?
 894         BPL     PFNDCH
 895         ANDB    #$7F    ; Clear high bit from dictionary.
 896         CMPB    ,Y+     ; Compare "last" characters.
 897         BEQ     FOUND   ; Matches even if dictionary actual length is shorter.
 898 PFNDLN  LDX     ,X++    ; Get previous link in vocabulary.
 899         BNE     PFNDLP  ; Continue if link not=0
 900 *
 901 *       not found :
 902         LEAU    2,U     ; Return only false flag.
 903         LDD     #0
 904         STD     ,U
 905         PULS    Y,PC
 906 *
 907 PFNDCH  CMPB    ,Y+     ; Compare characters.
 908         BEQ     PFNDBR
 909 PFNDUN
 910 PFNDSC  LDB     ,X+     ; scan forward to end of this name in dictionary
 911         BPL     PFNDSC
 912         BRA     PFNDLN
 913 *
 914 *       found :
 915 *
 916 FOUND   LEAX    4,X
 917         STX     2,U
 918         TFR     A,B
 919         CLRA
 920         STD     ,U
 921         LDB #1
 922         PSHU    A,B
 923         PULS    Y,PC
 924 *
 925 *       NOP     ; Probably leftovers from a debugging session.
 926 *       NOP
 927 * PD    EQU     N       ptr to dict word being checked
 928 * PA0   EQU     N+2
 929 * PA    EQU     N+4
 930 * PC    EQU     N+6
 931 *       LDX     #PD
 932 *       LDB #4
 933 * PFIND0        PULS A  ; loop to get arguments
 934 *       STA 0,X
 935 *       LEAX 1,X        ;
 936 *       DECB    ;
 937 *       BNE     PFIND0
 938 *
 939 *       LDX     PD
 940 * PFNDLP        LDB 0,X get count dict count
 941 *       STB PC
 942 *       ANDB #$3F
 943 *       LEAX 1,X        ;
 944 *       STX     PD      update PD
 945 *       LDX     PA0
 946 *       LDA 0,X get count from arg
 947 *       LEAX 1,X        ;
 948 *       STX     PA      intialize PA
 949 *       PSHS B  ; ** emulating CBA:
 950 *       CMPA ,S+        ;               compare lengths
 951 *       BNE     PFNDUN
 952 * PFNDBR        LDX     PA
 953 *       LDA 0,X
 954 *       LEAX 1,X        ;
 955 *       STX     PA
 956 *       LDX     PD
 957 *       LDB 0,X
 958 *       LEAX 1,X        ;
 959 *       STX     PD
 960 *       TSTB    ;               is dict entry neg. ?
 961 *       BPL     PFNDCH
 962 *       ANDB #$7F       clear sign
 963 *       PSHS B  ; ** emulating CBA:
 964 *       CMPA ,S+        ;
 965 *       BEQ     FOUND
 966 * PFNDLN        LDX     0,X     get new link
 967 *       BNE     PFNDLP  continue if link not=0
 968 *
 969 *       not found :
 970 *
 971 *       CLRA    ;
 972 *       CLRB    ;
 973 *       JMP     PUSHBA
 974 * PFNDCH        PSHS B  ; ** emulating CBA:
 975 *       CMPA ,S+        ;
 976 *       BEQ     PFNDBR
 977 * PFNDUN        LDX     PD
 978 * PFNDSC        LDB 0,X scan forward to end of this name
 979 *       LEAX 1,X        ;
 980 *       BPL     PFNDSC
 981 *       BRA     PFNDLN
 982 *
 983 *       found :
 984 *
 985 * FOUND LDA PD  compute CFA
 986 *       LDB PD+1
 987 *       ADDB #4
 988 *       ADCA #0
 989 *       PSHS B  ;
 990 *       PSHS A  ;
 991 *       LDA PC
 992 *       PSHS A  ;
 993 *       CLRA    ;
 994 *       PSHS A  ;
 995 *       LDB #1
 996 *       JMP     PUSHBA
 997 *
 998 *       PSHS A  ; Left over from a stray copy-paste, I guess.
 999 *       CLRA    ;
1000 *       PSHS A  ;
1001 *       LDB #1
1002 *       JMP     PUSHBA
1003 *
1004 * ######>> screen 20 <<
1005 * ======>>  12  <<
1006 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
1007 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
1008 * ( buffer ch --- buffer nuloffset onepast scancount )
1009 * Scan buffer for a symbol delimited by ch or ASCII NUL,
1010 * return the length of the buffer region scanned,
1011 * the offset to the trailing delimiter,
1012 * and the offset of the first character of the symbol.
1013 * Leave the buffer on the stack.
1014 * Scancount is also offset to first character not yet looked at.
1015 * If no symbol in buffer, scancount and symboloffset point to NUL
1016 * and delimiteroffset points one beyond for some reason.
1017 * On trailing NUL, delimiteroffset == scancount.
1018 * (Buffer is the address of the buffer array to scan.)
1019 * (This is a bit too tricky, really.)
1020         FCB     $87
1021         FCC     'ENCLOS'        ; 'ENCLOSE'
1022         FCB     $C5
1023         FDB     PFIND-9
1024 ENCLOS  FDB     *+NATWID
1025         LDA     1,U     ; Delimiter character to match against in A.
1026         LDX     2,U     ; Buffer to scan in.
1027         CLRB            ; Initialize offset. (Buffer < 256 wide!)
1028 *       Scan to a non-delimiter or a NUL
1029 ENCDEL  TST     B,X     ; NUL ?
1030         BEQ     ENCNUL
1031         CMPA    B,X     ; Delimiter?
1032         BNE     ENC1ST
1033         INCB            ; count character
1034         BRA     ENCDEL
1035 *       Found first character. Save the offset.
1036 ENC1ST  STB     1,U     ; Found first non-delimiter character --
1037         CLR     ,U      ; store the count, zero high byte.
1038 *       Scan to a delimiter or a NUL
1039 ENCSYM  TST     B,X     ; NUL ?
1040         BEQ     ENC0TR
1041         CMPA    B,X     ; delimiter?
1042         BEQ     ENCEND
1043         INCB
1044         BRA     ENCSYM
1045 *       Found end of symbol. Push offset to delimiter found.
1046 ENCEND  CLRA            ; high byte -- buffer < 255 wide!
1047         PSHU    A,B     ; Offset to seen delimiter.
1048 *       Advance and push address of next character to check.
1049         ADDD    #1      ; In case offset was 255.
1050         PSHU    A,B
1051         RTS
1052 *       Found NUL before non-delimiter, therefore there is no word
1053 ENCNUL  CLRA            ; high byte -- buffer < 255 wide!
1054         STD     ,U      ; offset to NUL.
1055         ADDD    #1      ; For some reason, point after NUL.
1056         PSHU    A,B     ;
1057         SUBD    #1      ; Next is not passed NUL.
1058         PSHU    A,B     ; Stealing code will save only one byte.
1059         RTS
1060 *       Found NUL following the word instead of delimiter.
1061 ENC0TR  PSHU    A,B     ; Save offset to first after symbol (NUL)
1062         PSHU    A,B     ; and count scanned.
1063         RTS
1064 * NOTE :
1065 * FC means offset (bytes) to First Character of next word
1066 * EW  "     "   to End of Word
1067 * NC  "     "   to Next Character to start next enclose at
1068 * ENCLOS        FDB     *+NATWID
1069 *       LEAS 1,S        ;
1070 *       PULS B  ; now, get the low byte, for an 8-bit delimiter
1071 *       TFR S,X ; TSX :
1072 *       LDX     0,X
1073 *       CLR N
1074 * *     wait for a non-delimiter or a NUL
1075 * ENCDEL        LDA 0,X
1076 *       BEQ     ENCNUL
1077 *       PSHS B  ; ** emulating CBA:
1078 *       CMPA ,S+        ;               CHECK FOR DELIM
1079 *       BNE     ENC1ST
1080 *       LEAX 1,X        ;
1081 *       INC N
1082 *       BRA     ENCDEL
1083 * *     found first character. Push FC
1084 * ENC1ST        LDA N   found first char.
1085 *       PSHS A  ;
1086 *       CLRA    ;
1087 *       PSHS A  ;
1088 *       wait for a delimiter or a NUL
1089 * ENCSYM        LDA 0,X
1090 *       BEQ     ENC0TR
1091 *       PSHS B  ; ** emulating CBA:
1092 *       CMPA ,S+        ;               ckech for delim.
1093 *       BEQ     ENCEND
1094 *       LEAX 1,X        ;
1095 *       INC N
1096 *       BRA     ENCSYM
1097 * *     found EW. Push it
1098 * ENCEND        LDB N
1099 *       CLRA    ;
1100 *       PSHS B  ;
1101 *       PSHS A  ;
1102 * *     advance and push NC
1103 *       INCB    ;
1104 *       JMP     PUSHBA
1105 *       found NUL before non-delimiter, therefore there is no word
1106 * ENCNUL        LDB N   found NUL
1107 *       PSHS B  ;
1108 *       PSHS A  ;
1109 *       INCB    ;
1110 *       BRA     ENC0TR+2        ; ********** POTENTIAL BUG HERE *******
1111 * ******** Should use labels in case opcodes change! ********
1112 *       found NUL following the word instead of SPACE
1113 * ENC0TR        LDB N
1114 *       PSHS B  ; save EW
1115 *       PSHS A  ;
1116 * ENCL8 LDB N   save NC
1117 *       JMP     PUSHBA
1118
1119         PAGE
1120 *
1121 * ######>> screen 21 <<
1122 * The next 4 words call system dependant I/O routines
1123 * which are listed after word "-->" ( lable: "arrow" )
1124 * in the dictionary.
1125 *
1126 * ======>>  13  <<
1127 * ( c --- )
1128 * Write c to the output device (screen or printer).
1129 * ROM Uses the ECB device number at address $6F,
1130 * -2 is printer, 0 is screen.
1131         FCB     $84
1132         FCC     'EMI'   ; 'EMIT'
1133         FCB     $D4
1134         FDB     ENCLOS-10
1135 EMIT    FDB     *+NATWID
1136         LBSR    PEMIT   ; PEMIT handles the stack.
1137         INC     <XOUT+1
1138         BNE     EMITDN
1139         INC     <XOUT
1140 EMITDN  RTS
1141 *       PULS A  ;
1142 *       PULS A  ;
1143 *       JSR     PEMIT
1144 *       LDX     UP
1145 *       INC XOUT+1-UORIG,X
1146 *       BNE *+4 ;
1147 *       ****WARNING**** HARD OFFSET: *+4 ****
1148 *       INC XOUT-UORIG,X
1149 *       JMP     NEXT
1150 *
1151 * ======>>  14  <<
1152 * ( --- c )
1153 * ( --- BREAK )
1154 * Wait for a key from the keyboard.
1155 * If the key is BREAK, set the high byte (result $FF03).
1156         FCB     $83
1157         FCC     'KE'    ; 'KEY'
1158         FCB     $D9
1159         FDB     EMIT-7
1160 KEY     FDB     *+NATWID
1161         LBSR    PKEY    ; PKEY handles the stack.
1162         RTS
1163 *       JSR     PKEY
1164 *       PSHS A  ;
1165 *       CLRA    ;
1166 *       PSHS A  ;
1167 *       JMP     NEXT
1168 *
1169 * ======>>  15  <<
1170 * ( --- f )
1171 * Scan keyboard, but do not wait.
1172 * Return 0 if no key,
1173 * BREAK ($ff03) if BREAK is pressed,
1174 * or key currently pressed.
1175         FCB     $89
1176         FCC     '?TERMINA'      ; '?TERMINAL'
1177         FCB     $CC
1178         FDB     KEY-6
1179 QTERM   FDB     *+NATWID
1180         LBSR    PQTER   ; PQTER handles the stack.
1181         RTS
1182 *       JSR     PQTER
1183 *       CLRB    ;
1184 *       JMP     PUSHBA  stack the flag
1185 *
1186 * ======>>  16  <<
1187 * ( --- )
1188 * EMIT a Carriage Return (ASCII CR).
1189         FCB     $82
1190         FCC     'C'     ; 'CR'
1191         FCB     $D2
1192         FDB     QTERM-12
1193 CR      FDB     *+NATWID
1194         LBSR    PCR     ; PCR handles the stack.
1195         RTS
1196 *       JSR     PCR
1197 *       JMP     NEXT
1198 *
1199 * ######>> screen 22 <<
1200 * ======>>  17  <<
1201 * ( source target count --- )
1202 * Copy/move count bytes from source to target.
1203 * Moves ascending addresses,
1204 * so that overlapping only works if the source is above the destination.
1205         FCB     $85
1206         FCC     'CMOV'  ; 'CMOVE' :     source, destination, count
1207         FCB     $C5
1208         FDB     CR-5
1209 CMOVE   FDB     *+NATWID
1210 * One way:              ; takes ( 37+17*count+9*(count/256) cycles )
1211         PSHS    Y       ; #2~7 ; Gotta have our pointers.
1212         PULU    D,X,Y   ; #2~11
1213         PSHS    A       ; #2~6 ; Gotta have our pointers.
1214         BRA     CMOVLE  ; #2~3
1215 CMOVLP
1216         LDA     ,Y+     ; #2~6
1217         STA     ,X+     ; #2~6
1218 CMOVLE
1219         SUBB    #1      ; #2~2
1220         BCC     CMOVLP  ; #2~3
1221         DEC     ,S      ; #2=6
1222         BPL     CMOVLP  ; #2~3
1223         PULS    A,Y,PC  ; #2~10
1224 * Another way           ; takes ( 42+17*count+9*(count/256) cycles )
1225 *       LDD #0          ; #3~3
1226 *       SUBD ,U++       ; #2~9 ; invert the count
1227 *       PSHS A,Y        ; #2~8
1228 *       PULU X,Y        ; #2~9
1229 *       BEQ CMOVEX      ; #2~3
1230 * CMOVEL
1231 *       LDA ,Y+         ; #2~6
1232 *       STA ,X+         ; #2~6
1233 *       INCB            ; #1~2
1234 *       BNE CMOVEL      ; #2~3
1235 *       INC ,S          ; #2~6
1236 *       BNE CMOVEL      ; #2~3
1237 * CMOVEX
1238 *       PULS A,Y,PC     ; #2~10
1239 * Yet another way               ; takes ( 37+29*count cycles )
1240 *       PSHS    Y       ; #2~7
1241 *       LDX     2,U     ; #2~6
1242 *       LDY     4,U     ; #3~7
1243 *       BRA     CMOVLE  ; #2~3
1244 * CMOVLP
1245 *       LDA     ,Y+     ; #2~6
1246 *       STA     ,X+     ; #2~6
1247 * CMOVLE
1248 *       LDD     ,U      ; #2~5
1249 *       SUBD    #1      ; #3~4
1250 *       STD     ,U      ; #2~5
1251 *       BPL     CMOVLP  ; #2~3
1252 *       LEAU    6,U     ; #2~5
1253 *       PULS    Y,PC    ; #2~9
1254 * Yet another way               ; takes ( 44+24*odd+33*count/2 cycles )
1255 *       PSHS    Y       ; #2~7
1256 *       LDX     2,U     ; #2~6
1257 *       LDY     4,U     ; #3~7
1258 *       LDD     ,U      ; #2~5
1259 *       BITB    #1      ; #2~2
1260 *       BEQ     CMOVLE  ; #2~3
1261 *       SUBD    #1      ; #3~4
1262 *       STD     ,U      ; #2~5
1263 *       LDA     ,Y+     ; #2~6
1264 *       STA     ,X+     ; #2~6
1265 *       BRA     CMOVLE  ; #2~3
1266 * CMOVLP
1267 *       LDD     ,Y++    ; #2~8
1268 *       STD     ,X++    ; #2~8
1269 * CMOVLI
1270 *       LDD     ,U      ; #2~5
1271 * CMOVLE
1272 *       SUBD    #2      ; #3~4
1273 *       STD     ,U      ; #2~5
1274 *       BPL     CMOVLP  ; #2~3
1275 *       LEAU    6,U     ; #2~5
1276 *       PULS    Y,PC    ; #2~9
1277 * From the 6800 model:
1278 * CMOVE FDB     *+2     takes ( 43+47*count cycles ) on 6800
1279 *       LDX     #N
1280 *       LDB #6
1281 * CMOV1 PULS A  ;
1282 *       STA 0,X move parameters to scratch area
1283 *       LEAX 1,X        ;
1284 *       DECB    ;
1285 *       BNE     CMOV1
1286 * CMOV2 LDA N
1287 *       LDB N+1
1288 *       SUBB #1
1289 *       SBCA #0
1290 *       STA N
1291 *       STB N+1
1292 *       BCS     CMOV3
1293 *       LDX     N+4
1294 *       LDA 0,X
1295 *       LEAX 1,X        ;
1296 *       STX     N+4
1297 *       LDX     N+2
1298 *       STA 0,X
1299 *       LEAX 1,X        ;
1300 *       STX     N+2
1301 *       BRA     CMOV2
1302 * CMOV3 JMP     NEXT
1303 *
1304 * ######>> screen 23 <<
1305 * ======>>  18  <<
1306 * ( u1 u2 --- ud )
1307 * Multiplies the top two unsigned integers,
1308 * yielding a double integer product.
1309         FCB     $82
1310         FCC     'U'     ; 'U*'
1311         FCB     $AA
1312         FDB     CMOVE-8
1313 USTAR   FDB     *+NATWID
1314         LEAU    -4,U
1315         LDA     5,U     ; least
1316         LDB     7,U
1317         MUL
1318         STD     2,U
1319         LDA     4,U     ; most
1320         LDB     6,U
1321         MUL
1322         STD     ,U
1323         LDD     5,U     ; first inner (u2 lo, u1 hi)
1324         MUL
1325         ADDD    1,U
1326         BCC     USTAR3
1327         INC     ,U
1328 USTAR3  STD     1,U
1329         LDA     4,U     ; second inner (u2 hi)
1330         LDB     7,U     ; (u1 lo)
1331         MUL
1332         ADDD    1,U
1333         BCC     USTAR4
1334         INC     ,U
1335 USTAR4  STD     1,U
1336         PULS    D,X
1337         STD     ,U
1338         STX     2,U
1339         RTS
1340 *       BSR     USTARS
1341 *       LEAS 1,S        ;
1342 *       LEAS 1,S        ;
1343 *       JMP     PUSHBA
1344 *
1345 * The following is a subroutine which
1346 * multiplies top 2 words on stack,
1347 * leaving 32-bit result:  high order word in A,B
1348 * low order word in 2nd word of stack.
1349 *
1350 * USTARS        LDA #16 bits/word counter
1351 *       PSHS A  ;
1352 *       CLRA    ;
1353 *       CLRB    ;
1354 *       TFR S,X ; TSX :
1355 * USTAR2        ROR 5,X shift multiplier
1356 *       ROR 6,X
1357 *       DEC 0,X done?
1358 *       BMI     USTAR4
1359 *       BCC     USTAR3
1360 *       ADDB 4,X
1361 *       ADCA 3,X
1362 * USTAR3        RORA    ;
1363 *       RORB    ;               shift result
1364 *       BRA     USTAR2
1365 * USTAR4        LEAS 1,S        ;               dump counter
1366 *       RTS
1367 *
1368 * ######>> screen 24 <<
1369 * ======>>  19  <<
1370 * ( ud u --- uremainder uquotient )
1371 * Divides the top unsigned integer
1372 * into the second and third words on the stack
1373 * as a single unsigned double integer,
1374 * leaving the remainder and quotient (quotient on top)
1375 * as unsigned integers.
1376 *
1377 *    The smaller the divisor, the more likely dropping the high word
1378 *    of the quotient loses significant bits.
1379 *
1380         FCB     $82
1381         FCC     'U'     ; 'U/'
1382         FCB     $AF
1383         FDB     USTAR-5
1384 USLASH  FDB     *+NATWID
1385         LDA     #17     ; bit ct
1386         PSHS    A
1387         LDD     2,U     ; dividend
1388 USLDIV  CMPD    ,U      ; divisor
1389         BHS     USLSUB
1390         ANDCC   #~1     ; carry clear
1391         BRA     USLBIT
1392 USLSUB  SUBD    ,U
1393         ORCC    #1      ; quotient, (carry set)
1394 USLBIT  ROL     5,U     ; save it
1395         ROL     4,U
1396         DEC     ,S      ; more bits?
1397         BEQ     USLR
1398         ROLB            ; remainder
1399         ROLA
1400         BCC     USLDIV
1401         BRA     USLSUB
1402 USLR    LEAU    2,U
1403         LDX     2,U
1404         STD     2,U
1405         STX     ,U
1406         PULS    A,PC    ; Avoiding a LEAS 1,S by discarding A.
1407 *       LDA #17
1408 *       PSHS A  ;
1409 *       TFR S,X ; TSX :
1410 *       LDA 3,X
1411 *       LDB 4,X
1412 * USL1  CMPA 1,X
1413 *       BHI     USL3
1414 *       BCS     USL2
1415 *       CMPB 2,X
1416 *       BCC     USL3
1417 * USL2  ANDCC #~$01     ; CLC :
1418 *       BRA     USL4
1419 * USL3  SUBB 2,X
1420 *       SBCA 1,X
1421 *       ORCC #$01       ; SEC :
1422 * USL4  ROL 6,X
1423 *       ROL 5,X
1424 *       DEC 0,X
1425 *       BEQ     USL5
1426 *       ROLB    ;
1427 *       ROLA    ;
1428 *       BCC     USL1
1429 *       BRA     USL3
1430 * USL5  LEAS 1,S        ;
1431 *       LEAS 1,S        ;
1432 *       LEAS 1,S        ;
1433 *       LEAS 1,S        ;
1434 *       LEAS 1,S        ;
1435 *       JMP     SWAP+4  reverse quotient & remainder
1436 *
1437 * ######>> screen 25 <<
1438 * ======>>  20  <<
1439 * ( n1 n2 --- n )
1440 * Bitwise and the top two integers.
1441         FCB     $83
1442         FCC     'AN'    ; 'AND'
1443         FCB     $C4
1444         FDB     USLASH-5
1445 AND     FDB     *+NATWID
1446         PULU    A,B
1447         ANDB    1,U
1448         ANDA    ,U
1449         STD     ,U
1450         RTS
1451 *       PULS A  ;
1452 *       PULS B  ;
1453 *       TFR S,X ; TSX :
1454 *       ANDB 1,X
1455 *       ANDA 0,X
1456 *       JMP     STABX
1457 *
1458 * ======>>  21  <<
1459 * ( n1 n2 --- n )
1460 * Bitwise or the top two integers.
1461         FCB     $82
1462         FCC     'O'     ; 'OR'
1463         FCB     $D2
1464         FDB     AND-6
1465 OR      FDB     *+NATWID
1466         PULU    A,B
1467         ORB     1,U
1468         ORA     ,U
1469         STD     ,U
1470         RTS
1471 *       PULS A  ;
1472 *       PULS B  ;
1473 *       TFR S,X ; TSX :
1474 *       ORB 1,X
1475 *       ORA 0,X
1476 *       JMP     STABX
1477 *
1478 * ======>>  22  <<
1479 * ( n1 n2 --- n )
1480 * Bitwise exclusive or the top two integers.
1481         FCB     $83
1482         FCC     'XO'    ; 'XOR'
1483         FCB     $D2
1484         FDB     OR-5
1485 XOR     FDB     *+NATWID
1486         PULU    A,B
1487         EORB    1,U
1488         EORA    ,U
1489         STD     ,U
1490         RTS
1491 *       PULS A  ;
1492 *       PULS B  ;
1493 *       TFR S,X ; TSX :
1494 *       EORB 1,X
1495 *       EORA 0,X
1496 *       JMP     STABX
1497 *
1498 * ######>> screen 26 <<
1499 * ======>>  23  <<
1500 * ( --- adr )
1501 * Fetch the parameter stack pointer (before it is pushed).
1502 * This points at whatever was on the top of stack before.
1503         FCB     $83
1504         FCC     'SP'    ; 'SP@'
1505         FCB     $C0
1506         FDB     XOR-6
1507 SPAT    FDB     *+NATWID
1508         TFR     U,X
1509         PSHU    X
1510         RTS
1511 *       TFR S,X ; TSX :
1512 *       STX     N       scratch area
1513 *       LDX     #N
1514 *       JMP     GETX
1515 *
1516 * ======>>  24  <<
1517 * ( whatever --- nothing )
1518 * Initialize the parameter stack pointer from the USER variable S0.
1519 * Effectively clears the stack.
1520         FCB     $83
1521         FCC     'SP'    ; 'SP!'
1522         FCB     $A1
1523         FDB     SPAT-6
1524 SPSTOR  FDB     *+NATWID
1525         LDU     <XSPZER
1526         RTS
1527 *       LDX     UP
1528 *       LDX     XSPZER-UORIG,X
1529 *       TFR X,S ; TXS :                 watch it ! X and S are not equal on 6800.
1530 *       JMP     NEXT
1531 * ======>>  25  <<
1532 * ( whatever *** nothing )
1533 * Initialize the return stack pointer from the initialization table
1534 * instead of the user variable R0, for some reason.
1535 * Quite possibly, this should be from R0.
1536 * Effectively aborts all in process definitions, except the active one.
1537 * An emergency measure, to be sure.
1538 * The routine that calls this must never execute a return.
1539 * So this should never be executed from the terminal, I guess.
1540 * This is another that should be compile-time only, and in a separate vocabulary.
1541         FCB     $83
1542         FCC     'RP'    ; 'RP!'
1543         FCB     $A1
1544         FDB     SPSTOR-6
1545 RPSTOR  FDB     *+NATWID
1546         PULS    X       ; But this guy has to return to his caller.
1547         LDS     RINIT
1548         JMP     ,X
1549 *       LDX     RINIT   initialize from rom constant
1550 *       STX     RP
1551 *       JMP     NEXT
1552 *
1553 * ======>>  26  <<
1554 * ( ip *** )
1555 * Pop IP from return stack (return from high-level definition).
1556 * Can be used in a screen to force interpretion to terminate.
1557 * Must not be executed when temporaries are saved on top of the return stack.
1558         FCB     $82
1559         FCC     ';'     ; ';S'
1560         FCB     $D3
1561         FDB     RPSTOR-6
1562 SEMIS   FDB     *+NATWID
1563         PULS    D,X
1564         TFR     D,PC    ; and discard X.
1565 *       LDX     RP
1566 *       LEAX 1,X        ;
1567 *       LEAX 1,X        ;
1568 *       STX     RP
1569 *       LDX     0,X     get address we have just finished.
1570 *       JMP     NEXT+2  increment the return address & do next word
1571 *
1572 * ######>> screen 27 <<
1573 * ======>>  27  <<
1574 * ( limit index *** index index )
1575 * Force the terminating condition for the innermost loop by
1576 * copying its index to its limit.
1577 * Termination is postponed until the next
1578 * LOOP or +LOOP instruction is executed.
1579 * The index remains available for use until
1580 * the LOOP or +LOOP instruction is encountered.
1581 * Note that the assumption is that the current count is the correct count
1582 * to end at, rather than pushing the count to the final count.
1583         FCB     $85
1584         FCC     'LEAV'  ; 'LEAVE'
1585         FCB     $C5
1586         FDB     SEMIS-5
1587 LEAVE   FDB     *+NATWID
1588         LDD     2,S     ; Dodge the return address.
1589         STD     4,S
1590         RTS
1591 *       LDX     RP
1592 *       LDA 2,X
1593 *       LDB 3,X
1594 *       STA 4,X
1595 *       STB 5,X
1596 *       JMP     NEXT
1597 *
1598 * ======>>  28  <<
1599 * ( n --- )
1600 * ( *** n )
1601 * Move top of parameter stack to top of return stack.
1602         FCB     $82
1603         FCC     '>'     ; '>R'
1604         FCB     $D2
1605         FDB     LEAVE-8
1606 TOR     FDB     *+NATWID
1607         PULU    A,B
1608         LDX     ,S
1609         STD     ,S      ; Put it where the return address was.
1610         JMP     ,X
1611 *       LDX     RP
1612 *       LEAX -1,X       ;
1613 *       LEAX -1,X       ;
1614 *       STX     RP
1615 *       PULS A  ;
1616 *       PULS B  ;
1617 *       STA 2,X
1618 *       STB 3,X
1619 *       JMP     NEXT
1620 *
1621 * ======>>  29  <<
1622 * ( --- n )
1623 * ( n *** )
1624 * Move top of return stack to top of parameter stack.
1625         FCB     $82
1626         FCC     'R'     ; 'R>'
1627         FCB     $BE
1628         FDB     TOR-5
1629 FROMR   FDB     *+NATWID
1630         PULS    D,X
1631         PSHU    X
1632         TFR     D,PC
1633 *       LDX     RP
1634 *       LDA 2,X
1635 *       LDB 3,X
1636 *       LEAX 1,X        ;
1637 *       LEAX 1,X        ;
1638 *       STX     RP
1639 *       JMP     PUSHBA
1640 *
1641 * ======>>  30  <<
1642 * ( --- n )
1643 * ( n *** n )
1644 * Copy the top of return stack to top of parameter stack.
1645 * A synonym for I.
1646         FCB     $81     R
1647         FCB     $D2
1648         FDB     FROMR-5
1649 R       FDB     I+NATWID
1650
1651 *       LDX     RP
1652 *       LEAX 1,X        ;
1653 *       LEAX 1,X        ;
1654 *       JMP     GETX
1655 *
1656 * ######>> screen 28 <<
1657 * ======>>  31  <<
1658 * ( n --- n=0 )
1659 * Logically invert top of stack;
1660 * or flag true if top is zero, otherwise false.
1661         FCB     $82
1662         FCC     '0'     ; '0='
1663         FCB     $BD
1664         FDB     R-4
1665 ZEQU    FDB     *+NATWID
1666         LDD     #0
1667         LDX     ,U
1668         BNE     ZEQUF
1669         INCB    ; 1 is true
1670 ZEQUF   STD     ,U
1671         RTS
1672 *       TFR S,X ; TSX :
1673 *       CLRA    ;
1674 *       CLRB    ;
1675 *       LDX     0,X
1676 *       BNE     ZEQU2
1677 *       INCB    ;
1678 *ZEQU2  TFR S,X ; TSX :
1679 *       JMP     STABX
1680 *
1681 * ======>>  32  <<
1682 * ( n --- n<0 )
1683 * Flag true if top is negative (MSbit set), otherwise false.
1684         FCB     $82
1685         FCC     '0'     ; '0<'
1686         FCB     $BC
1687         FDB     ZEQU-5
1688 ZLESS   FDB     *+NATWID
1689         LDD     #0
1690         TST     ,U
1691         BPL     ZLESSF
1692         INCB
1693 ZLESSF  STD     ,U
1694         RTS
1695 *       TFR S,X ; TSX :
1696 *       LDA #$80        check the sign bit
1697 *       ANDA 0,X
1698 *       BEQ     ZLESS2
1699 *       CLRA    ;               if neg.
1700 *       LDB #1
1701 *       JMP     STABX
1702 * ZLESS2        CLRB    ;
1703 *       JMP     STABX
1704 *
1705 * ######>> screen 29 <<
1706 * ======>>  33  <<
1707 * ( n1 n2 --- n1+n2 )
1708 * Add top two words.
1709         FCB     $81     '+'
1710         FCB     $AB
1711         FDB     ZLESS-5
1712 PLUS    FDB     *+NATWID
1713         PULU    A,B     ; #2~7
1714         ADDD    ,U      ; #2~6
1715         STD     ,U      ; #2~5
1716         RTS             ; #1~5  =#7~23
1717 *       PULS A  ;
1718 *       PULS B  ;
1719 *       TFR S,X ; TSX :
1720 *       ADDB 1,X
1721 *       ADCA 0,X
1722 *       JMP     STABX
1723 *
1724 * ======>>  34  <<
1725 * ( d1 d2 --- d1+d2 )
1726 * Add top two double integers.
1727         FCB     $82
1728         FCC     'D'     ; 'D+'
1729         FCB     $AB
1730         FDB     PLUS-4
1731 DPLUS   FDB     *+NATWID
1732         LDD     6,U
1733         ADDD    2,U
1734         STD     6,U
1735         LDD     4,U
1736         ADCB    1,U
1737         ADCA    ,U
1738         LEAU    4,U
1739         STD     ,U
1740         RTS
1741 *       TFR S,X ; TSX :
1742 *       ANDCC #~$01     ; CLC :
1743 *       LDB #4
1744 * DPLUS2        LDA 3,X
1745 *       ADCA 7,X
1746 *       STA 7,X
1747 *       LEAX -1,X       ;
1748 *       DECB    ;
1749 *       BNE     DPLUS2
1750 *       LEAS 1,S        ;
1751 *       LEAS 1,S        ;
1752 *       LEAS 1,S        ;
1753 *       LEAS 1,S        ;
1754 *       JMP     NEXT
1755 *
1756 * ======>>  35  <<
1757 * ( n --- -n )
1758 * Negate (two's complement) top of stack.
1759         FCB     $85
1760         FCC     'MINU'  ; 'MINUS'
1761         FCB     $D3
1762         FDB     DPLUS-5
1763 MINUS   FDB     *+NATWID
1764         LDD     #0      ; #3~3
1765         SUBD    ,U      ; #2~5
1766         STD     ,U      ; #2~5
1767         RTS             ; #1~5  = #8~18
1768 *       TFR S,X ; TSX :
1769 *       NEG 1,X
1770 *       BCC     MINUS2
1771 *       NEG 0,X
1772 *       BRA     MINUS3
1773 * MINUS2        COM 0,X
1774 * MINUS3        JMP     NEXT
1775 *
1776 * ======>>  36  <<
1777 * ( d --- -d )
1778 * Negate (two's complement) top two words on stack as a double integer.
1779         FCB     $86
1780         FCC     'DMINU' ; 'DMINUS'
1781         FCB     $D3
1782         FDB     MINUS-8
1783 DMINUS  FDB     *+NATWID
1784         LDD     #0      ; #3~3
1785         SUBD    2,U     ; #2~7
1786         STD     2,U     ; #2~7
1787         LDD     #0      ; #3~3
1788         SBCB    1,U     ; #2~5
1789         SBCA    ,U      ; #2~4
1790         STD     ,U      ; #2~5
1791         RTS             ; #1~5  = #17~39
1792 *       TFR S,X ; TSX :
1793 *       COM 0,X
1794 *       COM 1,X
1795 *       COM 2,X
1796 *       NEG 3,X
1797 *       BNE     DMINX
1798 *       INC 2,X
1799 *       BNE     DMINX
1800 *       INC 1,X
1801 *       BNE     DMINX
1802 *       INC 0,X
1803 * DMINX JMP     NEXT
1804 *
1805 * ######>> screen 30 <<
1806 * ======>>  37  <<
1807 * ( n1 n2 --- n1 n2 n1 )
1808 * Push a copy of the second word on stack.
1809         FCB     $84
1810         FCC     'OVE'   ; 'OVER'
1811         FCB     $D2
1812         FDB     DMINUS-9
1813 OVER    FDB     *+NATWID
1814         LDD     2,U
1815         PSHU    D
1816         RTS
1817 *       TFR S,X ; TSX :
1818 *       LDA 2,X
1819 *       LDB 3,X
1820 *       JMP     PUSHBA
1821 *
1822 * ======>>  38  <<
1823 * ( n --- )
1824 * Discard the top word on stack.
1825         FCB     $84
1826         FCC     'DRO'   ; 'DROP'
1827         FCB     $D0
1828         FDB     OVER-7
1829 DROP    FDB     *+NATWID
1830         LEAU    2,U
1831         RTS
1832 *       LEAS 1,S        ;
1833 *       LEAS 1,S        ;
1834 *       JMP     NEXT
1835 *
1836 * ======>>  39  <<
1837 * ( n1 n2 --- n2 n1 )
1838 * Swap the top two words on stack.
1839         FCB     $84
1840         FCC     'SWA'   ; 'SWAP'
1841         FCB     $D0
1842         FDB     DROP-7
1843 SWAP    FDB     *+NATWID
1844         PULU    D,X
1845         PSHU    D
1846         PSHU    X
1847         RTS
1848 *       PULS A  ;
1849 *       PULS B  ;
1850 *       TFR S,X ; TSX :
1851 *       LDX     0,X
1852 *       LEAS 1,S        ;
1853 *       LEAS 1,S        ;
1854 *       PSHS B  ;
1855 *       PSHS A  ;
1856 *       STX     N
1857 *       LDX     #N
1858 *       JMP     GETX
1859 *
1860 * ======>>  40  <<
1861 * ( n1 --- n1 n1 )
1862 * Push a copy of the top word on stack.
1863         FCB     $83
1864         FCC     'DU'    ; 'DUP'
1865         FCB     $D0
1866         FDB     SWAP-7
1867 DUP     FDB     *+NATWID
1868         LDD     ,U
1869         PSHU    D
1870         RTS
1871 *       PULS A  ;
1872 *       PULS B  ;
1873 *       PSHS B  ;
1874 *       PSHS A  ;
1875 *       JMP PUSHBA
1876 *
1877 * ######>> screen 31 <<
1878 * ======>>  41  <<
1879 * ( n adr --- )
1880 * Add the second word on stack to the word at the adr on top of stack.
1881         FCB     $82
1882         FCC     '+'     ; '+!'
1883         FCB     $A1
1884         FDB     DUP-6
1885 PSTORE  FDB     *+NATWID
1886         PULU    X
1887         LDD     ,X
1888         ADDD    ,U++
1889         STD     ,X
1890         RTS
1891 *       TFR S,X ; TSX :
1892 *       LDX     0,X
1893 *       LEAS 1,S        ;
1894 *       LEAS 1,S        ;
1895 *       PULS A  ; get stack data
1896 *       PULS B  ;
1897 *       ADDB 1,X        add & store low byte
1898 *       STB 1,X
1899 *       ADCA 0,X        add & store hi byte
1900 *       STA 0,X
1901 *       JMP     NEXT
1902 *
1903 * ======>>  42  <<
1904 * ( adr b --- )
1905 * Exclusive or byte at adr with low byte of top word.
1906         FCB     $86
1907         FCC     'TOGGL' ; 'TOGGLE'
1908         FCB     $C5
1909         FDB     PSTORE-5
1910 TOGGLE  FDB     *+NATWID
1911         PULU    D,X
1912         EORB    ,X
1913         STB     ,X
1914         RTS
1915 * Using the model code would be less likely to introduce bugs,
1916 * but that would sort-of defeat my purposes here.
1917 * Anyway, I can borrow from theoretically known good bif-6809 code
1918 * and it's fewer bytes and much faster code this way.
1919 * TOGGLE
1920 *       FDB     DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1921 *       FDB     SEMIS
1922 *
1923 * ######>> screen 32 <<
1924 * ======>>  43  <<
1925 * ( adr --- n )
1926 * Replace address on stack with the word at the address.
1927         FCB     $81     @
1928         FCB     $C0
1929         FDB     TOGGLE-9
1930 AT      FDB     *+NATWID
1931         LDD     [,U]
1932         STD     ,U
1933         RTS
1934 *       TFR S,X ; TSX :
1935 *       LDX     0,X     get address
1936 *       LEAS 1,S        ;
1937 *       LEAS 1,S        ;
1938 *       JMP     GETX
1939 *
1940 * ======>>  44  <<
1941 * ( adr --- b )
1942 * Replace address on top of stack with the byte at the address.
1943 * High byte of result is clear.
1944         FCB     $82
1945         FCC     'C'     ; 'C@'
1946         FCB     $C0
1947         FDB     AT-4
1948 CAT     FDB     *+NATWID
1949         LDB     [,U]
1950         CLRA
1951         STD     ,U
1952         RTS
1953
1954
1955 *       TFR S,X ; TSX :
1956 *       LDX     0,X
1957 *       CLRA    ;
1958 *       LDB 0,X
1959 *       LEAS 1,S        ;
1960 *       LEAS 1,S        ;
1961 *       JMP     PUSHBA
1962 *
1963 * ======>>  45  <<
1964 * ( n adr --- )
1965 * Store second word on stack at address on top of stack.
1966         FCB     $81
1967         FCB     $A1
1968         FDB     CAT-5
1969 STORE   FDB     *+NATWID
1970         LDD     2,U
1971         STD     [,U]
1972         LEAU    4,U
1973         RTS
1974 *       TFR S,X ; TSX :
1975 *       LDX     0,X     get address
1976 *       LEAS 1,S        ;
1977 *       LEAS 1,S        ;
1978 *       JMP     PULABX
1979 *
1980 * ======>>  46  <<
1981 * ( b adr --- )
1982 * Store low byte of second word on stack at address on top of stack.
1983 * High byte is ignored.
1984         FCB     $82
1985         FCC     'C'     ; 'C!'
1986         FCB     $A1
1987         FDB     STORE-4
1988 CSTORE  FDB     *+NATWID
1989         LDB     3,U
1990         STB     [,U]
1991         LEAU    4,U
1992         RTS
1993 *       TFR S,X ; TSX :
1994 *       LDX     0,X     get address
1995 *       LEAS 1,S        ;
1996 *       LEAS 1,S        ;
1997 *       LEAS 1,S        ;
1998 *       PULS B  ;
1999 *       STB 0,X
2000 *       JMP     NEXT
2001         PAGE
2002 *
2003 * ######>> screen 33 <<
2004 * ======>>  47  <<
2005 * ( --- )                                                 P
2006 * { : name sundry-activities ; } typical input
2007 * If executing (not compiling),
2008 * record the data stack mark in CSP,
2009 * Set the CONTEXT vocabulary to CURRENT,
2010 * CREATE a header,
2011 * set state to compile,
2012 * and compile the call to the trailing native CPU machine code DOCOL.
2013 * *** This would not be hard to flatten to native code. Maybe later.
2014         FCB     $C1     : immediate
2015         FCB     $BA
2016         FDB     CSTORE-5
2017 COLON   FDB     DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
2018         FDB     CREATE,RBRAK
2019         FDB     PSCODE
2020
2021 * Here is the IP pusher for allowing
2022 * nested words in the virtual machine:
2023 * ( ;S is the equivalent un-nester )
2024
2025 * ( *** oldIP )
2026 * Characteristic of a colon (:) definition.
2027 * Begins execution of a high-level definition,
2028 * i. e., nests the definition and begins processing icodes.
2029 * Mechanically, it pushes the IP (Y register)
2030 * and loads the Parameter Field Address of the definition which
2031 * called it into the IP.
2032 DOCOL   LDD     ,S      ; Save the return address.
2033         STY     ,S      ; Nest the old IP.
2034         LEAX    2,X     ; W still in X, bump to parameter field.
2035         TFR     X,Y     ; Load the new IP.
2036         TFR     D,PC    ; synthetic return to interpret.
2037
2038 * DOCOL LDX     RP      make room in the stack
2039 *       LEAX -1,X       ;
2040 *       LEAX -1,X       ;
2041 *       STX     RP
2042 *       LDA IP
2043 *       LDB IP+1
2044 *       STA 2,X Store address of the high level word
2045 *       STB 3,X that we are starting to execute
2046 *       LDX     W       Get first sub-word of that definition
2047 *       JMP     NEXT+2  and execute it
2048 *
2049 * ======>>  48  <<
2050 * ( --- )                                                 P
2051 * { : name sundry-activities ; } typical input
2052 * ERROR check data stack against mark in CSP,
2053 * compile ;S,
2054 * unSMUDGE LATEST definition,
2055 * and set state to interpretation.
2056         FCB     $C1     ;   imnediate code
2057         FCB     $BB
2058         FDB     COLON-4
2059 SEMI    FDB     DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
2060         FDB     SEMIS
2061 *
2062 * ######>> screen 34 <<
2063 * ======>>  49  <<
2064 * ( n --- )
2065 * { value CONSTANT name } typical input
2066 * CREATE a header,
2067 * unSMUDGE it,
2068 * compile the constant value,
2069 * and compile the call to the trailing native CPU machine code DOCON.
2070         FCB     $88
2071         FCC     'CONSTAN'       ; 'CONSTANT'
2072         FCB     $D4
2073         FDB     SEMI-4
2074 CON     FDB     DOCOL,CREATE,SMUDGE,COMMA,PSCODE
2075 * ( --- n )
2076 * Characteristic of a CONSTANT.
2077 * A CONSTANT simply loads its value from its parameter field
2078 * and pushes it on the stack.
2079 DOCON   LDD     2,X     ; Get the first natural width word of the parameter field.
2080         PSHU    D
2081         RTS
2082 * DOCON LDX     W
2083 *       LDA 2,X
2084 *       LDB 3,X A & B now contain the constant
2085 *       JMP     PUSHBA
2086 *
2087 * ======>>  50  <<
2088 * ( init --- )
2089 * { init VARIABLE name } typical input
2090 * CREATE a header and compile the initial value, init, using CONSTANT,
2091 * overwrite the characteristic to point to DOVAR.
2092         FCB     $88
2093         FCC     'VARIABL'       ; 'VARIABLE'
2094         FCB     $C5
2095         FDB     CON-11
2096 VAR     FDB     DOCOL,CON,PSCODE
2097 * ( --- vadr )
2098 * Characteristic of a VARIABLE.
2099 * A VARIABLE pushes its PFA address on the stack.
2100 * The parameter field of a VARIABLE is the actual allocation of the variable,
2101 * so that pushing its address allows its contents to be @ed (fetched).
2102 * Ordinary arrays and strings that do not subscript themselves
2103 * may be allocated by defining a variable
2104 * and immediately ALLOTting the remaining needed space.
2105 * VARIABLES are global to all users,
2106 * and thus should be hidden in resource monitors, but aren't.
2107 DOVAR   LEAX    2,X     ; Point to the first natural width word of the parameters.
2108         PSHU    X
2109         RTS
2110 * DOVAR LDA W
2111 *       LDB W+1
2112 *       ADDB #2
2113 *       ADCA #0 A,B now contain the address of the variable
2114 *       JMP     PUSHBA
2115 *
2116 * ======>>  51  <<
2117 * ( ub --- )
2118 * { uboffset USER name } typical input
2119 * CREATE a header and compile the unsigned byte offset in the per-USER table,
2120 * then overwrite the header with a call to DOUSER.
2121 * The USER is entirely responsible for maintaining allocation!
2122         FCB     $84
2123         FCC     'USE'   ; 'USER'
2124         FCB     $D2
2125         FDB     VAR-11
2126 USER    FDB     DOCOL,CON,PSCODE
2127 * ( --- vadr )
2128 * Characteristic of a per-USER variable.
2129 * USER variables are similiar to VARIABLEs,
2130 * but are allocated (by hand!) in the per-user table.
2131 * A USER variable's parameter field contains its offset in the per-user table.
2132 DOUSER  TFR     DP,A    ; Make a pointer to the direct page.
2133         CLRB
2134         ADDD    2,X     ; Add the offset to the per-user variable.
2135         PSHU    D
2136         RTS
2137 * Hey, the per-user table could actually be larger than 256 bytes!
2138 * But we knew that. It's just not as esthetic to calculate it this way.
2139 *
2140 * DOUSER        LDX     W       get offset  into user's table
2141 *       LDA 2,X
2142 *       LDB 3,X
2143 *       ADDB UP+1       add to users base address
2144 *       ADCA UP
2145 *       JMP     PUSHBA  push address of user's variable
2146 *
2147 * ######>> screen 35 <<
2148 * ======>>  52  <<
2149 * ( --- 0 )
2150         FCB     $81
2151         FCB     $B0     0
2152         FDB     USER-7
2153 ZERO    FDB     DOCON
2154         FDB     0000
2155 *
2156 * ======>>  53  <<
2157 * ( --- 1 )
2158         FCB     $81
2159         FCB     $B1     1
2160         FDB     ZERO-4
2161 ONE     FDB     DOCON
2162         FDB     1
2163 *
2164 * ======>>  54  <<
2165 * ( --- 2 )
2166         FCB     $81
2167         FCB     $B2     2
2168         FDB     ONE-4
2169 TWO     FDB     DOCON
2170         FDB     2
2171 *
2172 * ======>>  55  <<
2173 * ( --- 3 )
2174         FCB     $81
2175         FCB     $B3     3
2176         FDB     TWO-4
2177 THREE   FDB     DOCON
2178         FDB     3
2179 *
2180 * ======>>  56  <<
2181 * ( --- SP )
2182 * ASCII SPACE character
2183         FCB     $82
2184         FCC     'B'     ; 'BL'
2185         FCB     $CC
2186         FDB     THREE-4
2187 BL      FDB     DOCON   ascii blank
2188         FDB     $20
2189 *
2190 * ======>>  57  <<
2191 * This really shouldn't be a CONSTANT.
2192 * ( --- adr )
2193 * The base of the disk buffer space.
2194         FCB     $85
2195         FCC     'FIRS'  ; 'FIRST'
2196         FCB     $D4
2197         FDB     BL-5
2198 FIRST   FDB     DOCON
2199         FDB     BUFBAS
2200 *       FDB     MEMEND-528      (132 * NBLK)
2201 *
2202 * ======>>  58  <<
2203 * This really shouldn't be a CONSTANT.
2204 * ( --- adr )
2205 * The limit of the disk buffer space.
2206         FCB     $85
2207         FCC     'LIMI'  ; 'LIMIT' :     ( the end of memory +1 )
2208         FCB     $D4
2209         FDB     FIRST-8
2210 LIMIT   FDB     DOCON
2211         FDB     BUFBAS+BUFSZ
2212 *       FDB     MEMEND
2213 *
2214 * ======>>  59  <<
2215 * ( --- sectorsize )
2216 * The size, in bytes, of a buffer.
2217         FCB     $85
2218         FCC     'B/BU'  ; 'B/BUF' :     (bytes/buffer)
2219         FCB     $C6
2220         FDB     LIMIT-8
2221 BBUF    FDB     DOCON
2222         FDB     SECTSZ
2223 *       FDB     128
2224 *
2225 * ======>>  60  <<
2226 * ( --- blocksperscreen )
2227 * The size, in blocks, of a screen.
2228 * Should this be the same as NBLK, the number of block buffers maintained?
2229         FCB     $85
2230         FCC     'B/SC'  ; 'B/SCR' :     (blocks/screen)
2231         FCB     $D2
2232         FDB     BBUF-8
2233 BSCR    FDB     DOCON
2234         FDB     SCRSZ/SECTSZ
2235 *       FDB     8
2236 *       blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
2237 *
2238 * ======>>  61  <<
2239 * ( n --- adr )
2240 * Calculate the address of entry (#n/2) in the boot-up parameter table.
2241 * (Adds the base of the boot-up table to n.)
2242         FCB     $87
2243         FCC     '+ORIGI'        ; '+ORIGIN'
2244         FCB     $CE
2245         FDB     BSCR-8
2246 PORIG   FDB     DOCOL,LIT,ORIG,PLUS
2247         FDB     SEMIS
2248 *
2249 * ######>> screen 36 <<
2250 * ======>>  62  <<
2251 * ( n --- adr )
2252 * This is the per-task variable recording the initial parameter stack pointer.
2253         FCB     $82
2254         FCC     'S'     ; 'S0'
2255         FCB     $B0
2256         FDB     PORIG-10
2257 SZERO   FDB     DOUSER
2258         FDB     XSPZER-UORIG
2259 *
2260 * ======>>  63  <<
2261 * ( n --- adr )
2262 * This is the per-task variable recording the initial return stack pointer.
2263         FCB     $82
2264         FCC     'R'     ; 'R0'
2265         FCB     $B0
2266         FDB     SZERO-5
2267 RZERO   FDB     DOUSER
2268         FDB     XRZERO-UORIG
2269 *
2270 * ======>>  64  <<
2271 * ( --- vadr )
2272 * Terminal Input Buffer address.
2273 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
2274         FCB     $83
2275         FCC     'TI'    ; 'TIB'
2276         FCB     $C2
2277         FDB     RZERO-5
2278 TIB     FDB     DOUSER
2279         FDB     XTIB-UORIG
2280 *
2281 * ======>>  65  <<
2282 * ( --- maxnamewidth )
2283 * This is the maximum width to which symbol names will be recorded.
2284         FCB     $85
2285         FCC     'WIDT'  ; 'WIDTH'
2286         FCB     $C8
2287         FDB     TIB-6
2288 WIDTH   FDB     DOUSER
2289         FDB     XWIDTH-UORIG
2290 *
2291 * ======>>  66  <<
2292 * ( --- vadr )
2293 * Availability of error messages on disk.
2294 * Contains 1 if messages available,
2295 * 0 if not,
2296 * -1 if a disk error has occurred.
2297         FCB     $87
2298         FCC     'WARNIN'        ; 'WARNING'
2299         FCB     $C7
2300         FDB     WIDTH-8
2301 WARN    FDB     DOUSER
2302         FDB     XWARN-UORIG
2303 *
2304 * ======>>  67  <<
2305 * ( --- vadr )
2306 * Boundary for FORGET.
2307         FCB     $85
2308         FCC     'FENC'  ; 'FENCE'
2309         FCB     $C5
2310         FDB     WARN-10
2311 FENCE   FDB     DOUSER
2312         FDB     XFENCE-UORIG
2313 *
2314 * ======>>  68  <<
2315 * ( --- vadr )
2316 * Dictionary pointer, fetched by HERE.
2317         FCB     $82
2318         FCC     'D'     ; 'DP' :        points to first free byte at end of dictionary
2319         FCB     $D0
2320         FDB     FENCE-8
2321 DICTPT  FDB     DOUSER
2322         FDB     XDICTP-UORIG
2323 *
2324 * ======>>  68.5  <<
2325 * ( --- vadr ) ******* Need to check what this is!
2326 * Used in maintaining vocabularies.
2327 * I think it points to the "parent" vocabulary, but I'm not sure.
2328         FCB     $88
2329         FCC     'VOC-LIN'       ; 'VOC-LINK'
2330         FCB     $CB
2331         FDB     DICTPT-5
2332 VOCLIN  FDB     DOUSER
2333         FDB     XVOCL-UORIG
2334 *
2335 * ======>>  69  <<
2336 * ( --- vadr )
2337 * Disk block being interpreted.
2338 * Zero refers to terminal.
2339 * ******** Should be made a 32 bit variable! ********
2340 * But the base system needs to have full 32 bit support, div and mul, etc.
2341         FCB     $83
2342         FCC     'BL'    ; 'BLK'
2343         FCB     $CB
2344         FDB     VOCLIN-11
2345 BLK     FDB     DOUSER
2346         FDB     XBLK-UORIG
2347 *
2348 * ======>>  70  <<
2349 * ( --- vadr )
2350 * Input buffer offset/cursor.
2351         FCB     $82
2352         FCC     'I'     ; 'IN' :        scan pointer for input line buffer
2353         FCB     $CE
2354         FDB     BLK-6
2355 IN      FDB     DOUSER
2356         FDB     XIN-UORIG
2357 *
2358 * ======>>  71  <<
2359 * ( --- vadr )
2360 * Output buffer offset/cursor.
2361         FCB     $83
2362         FCC     'OU'    ; 'OUT'
2363         FCB     $D4
2364         FDB     IN-5
2365 OUT     FDB     DOUSER
2366         FDB     XOUT-UORIG
2367 *
2368 * ======>>  72  <<
2369 * ( --- vadr )
2370 * Screen currently being edited, once we have an editor running.
2371         FCB     $83
2372         FCC     'SC'    ; 'SCR'
2373         FCB     $D2
2374         FDB     OUT-6
2375 SCR     FDB     DOUSER
2376         FDB     XSCR-UORIG
2377 * ######>> screen 37 <<
2378 *
2379 * ======>>  73  <<
2380 * ( --- vadr )
2381 * Sector offset for LOADing screens,
2382 * set by DRIVE to make a new drive the default.
2383 * This should also be 32 bit or bigger.
2384         FCB     $86
2385         FCC     'OFFSE' ; 'OFFSET'
2386         FCB     $D4
2387         FDB     SCR-6
2388 OFSET   FDB     DOUSER
2389         FDB     XOFSET-UORIG
2390 *
2391 * ======>>  74  <<
2392 * ( --- vadr )
2393 * Current context of interpretation (vocabulary root).
2394         FCB     $87
2395         FCC     'CONTEX'        ; 'CONTEXT' :   points to pointer to vocab to search first
2396         FCB     $D4
2397         FDB     OFSET-9
2398 CONTXT  FDB     DOUSER
2399         FDB     XCONT-UORIG
2400 *
2401 * ======>>  75  <<
2402 * ( --- vadr )
2403 * Current context of definition (vocabulary root).
2404         FCB     $87
2405         FCC     'CURREN'        ; 'CURRENT' :   points to ptr. to vocab being extended
2406         FCB     $D4
2407         FDB     CONTXT-10
2408 CURENT  FDB     DOUSER
2409         FDB     XCURR-UORIG
2410 *
2411 * ======>>  76  <<
2412 * ( --- vadr )
2413 * Compiler/interpreter state.
2414         FCB     $85
2415         FCC     'STAT'  ; 'STATE' :     1 if compiling, 0 if not
2416         FCB     $C5
2417         FDB     CURENT-10
2418 STATE   FDB     DOUSER
2419         FDB     XSTATE-UORIG
2420 *
2421 * ======>>  77  <<
2422 * ( --- vadr )
2423 * Numeric conversion base.
2424         FCB     $84
2425         FCC     'BAS'   ; 'BASE' :      number base for all input & output
2426         FCB     $C5
2427         FDB     STATE-8
2428 BASE    FDB     DOUSER
2429         FDB     XBASE-UORIG
2430 *
2431 * ======>>  78  <<
2432 * ( --- vadr )
2433 * Decimal point location for output.
2434         FCB     $83
2435         FCC     'DP'    ; 'DPL'
2436         FCB     $CC
2437         FDB     BASE-7
2438 DPL     FDB     DOUSER
2439         FDB     XDPL-UORIG
2440 *
2441 * ======>>  79  <<
2442 * ( --- vadr )
2443 * Field width for I/O formatting.
2444         FCB     $83
2445         FCC     'FL'    ; 'FLD'
2446         FCB     $C4
2447         FDB     DPL-6
2448 FLD     FDB     DOUSER
2449         FDB     XFLD-UORIG
2450 *
2451 * ======>>  80  <<
2452 * ( --- vadr )
2453 * Compiler stack mark for stack check.
2454         FCB     $83
2455         FCC     'CS'    ; 'CSP'
2456         FCB     $D0
2457         FDB     FLD-6
2458 CSP     FDB     DOUSER
2459         FDB     XCSP-UORIG
2460 *
2461 * ======>>  81  <<
2462 * ( --- vadr )
2463 * Editing cursor location.
2464         FCB     $82
2465         FCC     'R'     ; 'R#'
2466         FCB     $A3
2467         FDB     CSP-6
2468 RNUM    FDB     DOUSER
2469         FDB     XRNUM-UORIG
2470 *
2471 * ======>>  82  <<
2472 * ( --- vadr )
2473 * Pointer to last HELD character in PAD.
2474         FCB     $83
2475         FCC     'HL'    ; 'HLD'
2476         FCB     $C4
2477         FDB     RNUM-5
2478 HLD     FDB     DOCON
2479         FDB     XHLD
2480 *
2481 * ======>>  82.5  <<== SPECIAL
2482 * ( --- vadr )
2483 * Line width of active terminal.
2484         FCB     $87
2485         FCC     'COLUMN'        ; 'COLUMNS' :   line width of terminal
2486         FCB     $D3
2487         FDB     HLD-6
2488 COLUMS  FDB     DOUSER
2489         FDB     XCOLUM-UORIG
2490 *
2491 * ######>> screen 38 <<
2492 ** Could make an incrementer compiling word:
2493 ** ( n --- )
2494 ** { n INCREMENTER name } typical input
2495 ** CREATE a header and compile the increment constant,
2496 ** then overwrite the header with a call to DOINC.
2497 *       FCB     $84
2498 *       FCC     'INCREMENTE'    ; INCREMENTER'
2499 *       FCB     $D2
2500 *       FDB     COLUMS-9
2501 * INCR  FDB     DOCOL,CON,PSCODE
2502 ** ( n --- ninc )
2503 ** Characteristic of an INCREMENTER.
2504 * DOINC LDD     ,U
2505 *       ADDD    2,X     ; Add the increment.
2506 *       STD     ,U
2507 *       RTS
2508 *
2509 * ======>>  83  <<
2510 * ( n --- n+1 )
2511         FCB     $82
2512         FCC     '1'     ; '1+'
2513         FCB     $AB
2514         FDB     COLUMS-10
2515 ONEP    FDB     *+NATWID
2516         LDD     ,U
2517         ADDD    #1
2518         STD     ,U
2519         RTS
2520 * ONEP  FDB     DOCOL,ONE,PLUS
2521 *       FDB     SEMIS
2522 *
2523 * ======>>  84  <<
2524 * ( n --- n+2 )
2525         FCB     $82
2526         FCC     '2'     ; '2+'
2527         FCB     $AB
2528         FDB     ONEP-5
2529 TWOP    FDB     *+NATWID
2530         LDD     ,U
2531         ADDD    #2
2532         STD     ,U
2533         RTS
2534 * TWOP  FDB     DOCOL,TWO,PLUS
2535 *       FDB     SEMIS
2536 *
2537 * ======>>  85  <<
2538         FCB     $84
2539         FCC     'HER'   ; 'HERE'
2540         FCB     $C5
2541         FDB     TWOP-5
2542 HERE    FDB     DOCOL,DICTPT,AT
2543         FDB     SEMIS
2544 *
2545 * ======>>  86  <<
2546         FCB     $85
2547         FCC     'ALLO'  ; 'ALLOT'
2548         FCB     $D4
2549         FDB     HERE-7
2550 ALLOT   FDB     DOCOL,DICTPT,PSTORE
2551         FDB     SEMIS
2552 *
2553 * ======>>  87  <<
2554         FCB     $81     ; , (COMMA)
2555         FCB     $AC
2556         FDB     ALLOT-8
2557 COMMA   FDB     DOCOL,HERE,STORE,TWO,ALLOT
2558         FDB     SEMIS
2559 *
2560 * ======>>  88  <<
2561         FCB     $82
2562         FCC     'C'     ; 'C,'
2563         FCB     $AC
2564         FDB     COMMA-4
2565 CCOMM   FDB     DOCOL,HERE,CSTORE,ONE,ALLOT
2566         FDB     SEMIS
2567 *
2568 * ======>>  89  <<
2569 * ( n1 n2 --- n1-n2 )
2570 * Subtract top two words.
2571         FCB     $81     ; -
2572         FCB     $AD
2573         FDB     CCOMM-5
2574 SUB     FDB     *+NATWID
2575         LDD     2,U     ; #2~6
2576         SUBD    ,U++    ; #2~9
2577         STD     ,U      ; #2~5
2578         RTS             ; #1~5  = #7~25
2579 * SUB   FDB     DOCOL,MINUS,PLUS
2580 *       FDB     SEMIS   ; Costs 6 bytes and lots of cycles.
2581 *
2582 * ======>>  90  <<
2583         FCB     $81     =
2584         FCB     $BD
2585         FDB     SUB-4
2586 EQUAL   FDB     DOCOL,SUB,ZEQU
2587         FDB     SEMIS
2588 *
2589 * ======>>  91  <<
2590         FCB     $81     <
2591         FCB     $BC
2592         FDB     EQUAL-4
2593 LESS    FDB     *+NATWID
2594         PULS A  ;
2595         PULS B  ;
2596         TFR S,X ; TSX :
2597         CMPA 0,X
2598         LEAS 1,S        ;
2599         BGT     LESST
2600         BNE     LESSF
2601         CMPB 1,X
2602         BHI     LESST
2603 LESSF   CLRB    ;
2604         BRA     LESSX
2605 LESST   LDB #1
2606 LESSX   CLRA    ;
2607         LEAS 1,S        ;
2608         JMP     PUSHBA
2609 *
2610 * ======>>  92  <<
2611         FCB     $81     >
2612         FCB     $BE
2613         FDB     LESS-4
2614 GREAT   FDB     DOCOL,SWAP,LESS
2615         FDB     SEMIS
2616 *
2617 * ======>>  93  <<
2618         FCB     $83
2619         FCC     'RO'    ; 'ROT'
2620         FCB     $D4
2621         FDB     GREAT-4
2622 ROT     FDB     DOCOL,TOR,SWAP,FROMR,SWAP
2623         FDB     SEMIS
2624 *
2625 * ======>>  94  <<
2626         FCB     $85
2627         FCC     'SPAC'  ; 'SPACE'
2628         FCB     $C5
2629         FDB     ROT-6
2630 SPACE   FDB     DOCOL,BL,EMIT
2631         FDB     SEMIS
2632 *
2633 * ======>>  95  <<
2634         FCB     $83
2635         FCC     'MI'    ; 'MIN'
2636         FCB     $CE
2637         FDB     SPACE-8
2638 MIN     FDB     DOCOL,OVER,OVER,GREAT,ZBRAN
2639         FDB     MIN2-*
2640         FDB     SWAP
2641 MIN2    FDB     DROP
2642         FDB     SEMIS
2643 *
2644 * ======>>  96  <<
2645         FCB     $83
2646         FCC     'MA'    ; 'MAX'
2647         FCB     $D8
2648         FDB     MIN-6
2649 MAX     FDB     DOCOL,OVER,OVER,LESS,ZBRAN
2650         FDB     MAX2-*
2651         FDB     SWAP
2652 MAX2    FDB     DROP
2653         FDB     SEMIS
2654 *
2655 * ======>>  97  <<
2656         FCB     $84
2657         FCC     '-DU'   ; '-DUP'
2658         FCB     $D0
2659         FDB     MAX-6
2660 DDUP    FDB     DOCOL,DUP,ZBRAN
2661         FDB     DDUP2-*
2662         FDB     DUP
2663 DDUP2   FDB     SEMIS
2664 *
2665 * ######>> screen 39 <<
2666 * ======>>  98  <<
2667         FCB     $88
2668         FCC     'TRAVERS'       ; 'TRAVERSE'
2669         FCB     $C5
2670         FDB     DDUP-7
2671 TRAV    FDB     DOCOL,SWAP
2672 TRAV2   FDB     OVER,PLUS,LIT8
2673         FCB     $7F
2674         FDB     OVER,CAT,LESS,ZBRAN
2675         FDB     TRAV2-*
2676         FDB     SWAP,DROP
2677         FDB     SEMIS
2678 *
2679 * ======>>  99  <<
2680         FCB     $86
2681         FCC     'LATES' ; 'LATEST'
2682         FCB     $D4
2683         FDB     TRAV-11
2684 LATEST  FDB     DOCOL,CURENT,AT,AT
2685         FDB     SEMIS
2686 *
2687 * ======>>  100  <<
2688         FCB     $83
2689         FCC     'LF'    ; 'LFA'
2690         FCB     $C1
2691         FDB     LATEST-9
2692 LFA     FDB     DOCOL,LIT8
2693         FCB     4
2694         FDB     SUB
2695         FDB     SEMIS
2696 *
2697 * ======>>  101  <<
2698         FCB     $83
2699         FCC     'CF'    ; 'CFA'
2700         FCB     $C1
2701         FDB     LFA-6
2702 CFA     FDB     DOCOL,TWO,SUB
2703         FDB     SEMIS
2704 *
2705 * ======>>  102  <<
2706         FCB     $83
2707         FCC     'NF'    ; 'NFA'
2708         FCB     $C1
2709         FDB     CFA-6
2710 NFA     FDB     DOCOL,LIT8
2711         FCB     5
2712         FDB     SUB,ONE,MINUS,TRAV
2713         FDB     SEMIS
2714 *
2715 * ======>>  103  <<
2716         FCB     $83
2717         FCC     'PF'    ; 'PFA'
2718         FCB     $C1
2719         FDB     NFA-6
2720 PFA     FDB     DOCOL,ONE,TRAV,LIT8
2721         FCB     5
2722         FDB     PLUS
2723         FDB     SEMIS
2724 *
2725 * ######>> screen 40 <<
2726 * ======>>  104  <<
2727         FCB     $84
2728         FCC     '!CS'   ; '!CSP'
2729         FCB     $D0
2730         FDB     PFA-6
2731 SCSP    FDB     DOCOL,SPAT,CSP,STORE
2732         FDB     SEMIS
2733 *
2734 * ======>>  105  <<
2735         FCB     $86
2736         FCC     '?ERRO' ; '?ERROR'
2737         FCB     $D2
2738         FDB     SCSP-7
2739 QERR    FDB     DOCOL,SWAP,ZBRAN
2740         FDB     QERR2-*
2741         FDB     ERROR,BRAN
2742         FDB     QERR3-*
2743 QERR2   FDB     DROP
2744 QERR3   FDB     SEMIS
2745 *
2746 * ======>>  106  <<
2747         FCB     $85
2748         FCC     '?COM'  ; '?COMP'
2749         FCB     $D0
2750         FDB     QERR-9
2751 QCOMP   FDB     DOCOL,STATE,AT,ZEQU,LIT8
2752         FCB     $11
2753         FDB     QERR
2754         FDB     SEMIS
2755 *
2756 * ======>>  107  <<
2757         FCB     $85
2758         FCC     '?EXE'  ; '?EXEC'
2759         FCB     $C3
2760         FDB     QCOMP-8
2761 QEXEC   FDB     DOCOL,STATE,AT,LIT8
2762         FCB     $12
2763         FDB     QERR
2764         FDB     SEMIS
2765 *
2766 * ======>>  108  <<
2767         FCB     $86
2768         FCC     '?PAIR' ; '?PAIRS'
2769         FCB     $D3
2770         FDB     QEXEC-8
2771 QPAIRS  FDB     DOCOL,SUB,LIT8
2772         FCB     $13
2773         FDB     QERR
2774         FDB     SEMIS
2775 *
2776 * ======>>  109  <<
2777         FCB     $84
2778         FCC     '?CS'   ; '?CSP'
2779         FCB     $D0
2780         FDB     QPAIRS-9
2781 QCSP    FDB     DOCOL,SPAT,CSP,AT,SUB,LIT8
2782         FCB     $14
2783         FDB     QERR
2784         FDB     SEMIS
2785 *
2786 * ======>>  110  <<
2787         FCB     $88
2788         FCC     '?LOADIN'       ; '?LOADING'
2789         FCB     $C7
2790         FDB     QCSP-7
2791 QLOAD   FDB     DOCOL,BLK,AT,ZEQU,LIT8
2792         FCB     $16
2793         FDB     QERR
2794         FDB     SEMIS
2795 *
2796 * ######>> screen 41 <<
2797 * ======>>  111  <<
2798         FCB     $87
2799         FCC     'COMPIL'        ; 'COMPILE'
2800         FCB     $C5
2801         FDB     QLOAD-11
2802 COMPIL  FDB     DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
2803         FDB     SEMIS
2804 *
2805 * ======>>  112  <<
2806         FCB     $C1     [       immediate
2807         FCB     $DB
2808         FDB     COMPIL-10
2809 LBRAK   FDB     DOCOL,ZERO,STATE,STORE
2810         FDB     SEMIS
2811 *
2812 * ======>>  113  <<
2813         FCB     $81     ]
2814         FCB     $DD
2815         FDB     LBRAK-4
2816 RBRAK   FDB     DOCOL,LIT8
2817         FCB     $C0
2818         FDB     STATE,STORE
2819         FDB     SEMIS
2820 *
2821 * ======>>  114  <<
2822         FCB     $86
2823         FCC     'SMUDG' ; 'SMUDGE'
2824         FCB     $C5
2825         FDB     RBRAK-4
2826 SMUDGE  FDB     DOCOL,LATEST,LIT8
2827         FCB     $20
2828         FDB     TOGGLE
2829         FDB     SEMIS
2830 *
2831 * ======>>  115  <<
2832         FCB     $83
2833         FCC     'HE'    ; 'HEX'
2834         FCB     $D8
2835         FDB     SMUDGE-9
2836 HEX     FDB     DOCOL
2837         FDB     LIT8
2838         FCB     16
2839         FDB     BASE,STORE
2840         FDB     SEMIS
2841 *
2842 * ======>>  116  <<
2843         FCB     $87
2844         FCC     'DECIMA'        ; 'DECIMAL'
2845         FCB     $CC
2846         FDB     HEX-6
2847 DEC     FDB     DOCOL
2848         FDB     LIT8
2849         FCB     10      note: hex "A"
2850         FDB     BASE,STORE
2851         FDB     SEMIS
2852 *
2853 * ######>> screen 42 <<
2854 * ======>>  117  <<
2855         FCB     $87
2856         FCC     '(;CODE'        ; '(;CODE)'
2857         FCB     $A9
2858         FDB     DEC-10
2859 PSCODE  FDB     DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
2860         FDB     SEMIS
2861 *
2862 * ======>>  118  <<
2863         FCB     $C5     immediate
2864         FCC     ';COD'  ; ';CODE'
2865         FCB     $C5
2866         FDB     PSCODE-10
2867 SEMIC   FDB     DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
2868         FDB     SEMIS
2869 * note: "QSTACK" will be replaced by "ASSEMBLER" later
2870 *
2871 * ######>> screen 43 <<
2872 * ======>>  119  <<
2873         FCB     $87
2874         FCC     '<BUILD'        ; '<BUILDS'
2875         FCB     $D3
2876         FDB     SEMIC-8
2877 BUILDS  FDB     DOCOL,ZERO,CON
2878         FDB     SEMIS
2879 *
2880 * ======>>  120  <<
2881         FCB     $85
2882         FCC     'DOES'  ; 'DOES>'
2883         FCB     $BE
2884         FDB     BUILDS-10
2885 DOES    FDB     DOCOL,FROMR,TWOP,LATEST,PFA,STORE
2886         FDB     PSCODE
2887 DODOES  LDA IP
2888         LDB IP+1
2889         LDX     RP      make room on return stack
2890         LEAX -1,X       ;
2891         LEAX -1,X       ;
2892         STX     RP
2893         STA 2,X push return address
2894         STB 3,X
2895         LDX     W       get addr of pointer to run-time code
2896         LEAX 1,X        ;
2897         LEAX 1,X        ;
2898         STX     N       stash it in scratch area
2899         LDX     0,X     get new IP
2900         STX     IP
2901         CLRA    ;               get address of parameter
2902         LDB #2
2903         ADDB N+1
2904         ADCA N
2905         PSHS B  ; and push it on data stack
2906         PSHS A  ;
2907         JMP     NEXT2
2908 *
2909 * ######>> screen 44 <<
2910 * ======>>  121  <<
2911         FCB     $85
2912         FCC     'COUN'  ; 'COUNT'
2913         FCB     $D4
2914         FDB     DOES-8
2915 COUNT   FDB     DOCOL,DUP,ONEP,SWAP,CAT
2916         FDB     SEMIS
2917 *
2918 * ======>>  122  <<
2919         FCB     $84
2920         FCC     'TYP'   ; 'TYPE'
2921         FCB     $C5
2922         FDB     COUNT-8
2923 TYPE    FDB     DOCOL,DDUP,ZBRAN
2924         FDB     TYPE3-*
2925         FDB     OVER,PLUS,SWAP,XDO
2926 TYPE2   FDB     I,CAT,EMIT,XLOOP
2927         FDB     TYPE2-*
2928         FDB     BRAN
2929         FDB     TYPE4-*
2930 TYPE3   FDB     DROP
2931 TYPE4   FDB     SEMIS
2932 *
2933 * ======>>  123  <<
2934         FCB     $89
2935         FCC     '-TRAILIN'      ; '-TRAILING'
2936         FCB     $C7
2937         FDB     TYPE-7
2938 DTRAIL  FDB     DOCOL,DUP,ZERO,XDO
2939 DTRAL2  FDB     OVER,OVER,PLUS,ONE,SUB,CAT,BL
2940         FDB     SUB,ZBRAN
2941         FDB     DTRAL3-*
2942         FDB     LEAVE,BRAN
2943         FDB     DTRAL4-*
2944 DTRAL3  FDB     ONE,SUB
2945 DTRAL4  FDB     XLOOP
2946         FDB     DTRAL2-*
2947         FDB     SEMIS
2948 *
2949 * ======>>  124  <<
2950         FCB     $84
2951         FCC     '(."'   ; '(.")'
2952         FCB     $A9
2953         FDB     DTRAIL-12
2954 PDOTQ   FDB     DOCOL,R,TWOP,COUNT,DUP,ONEP
2955         FDB     FROMR,PLUS,TOR,TYPE
2956         FDB     SEMIS
2957 *
2958 * ======>>  125  <<
2959         FCB     $C2     immediate
2960         FCC     '.'     ; '."'
2961         FCB     $A2
2962         FDB     PDOTQ-7
2963 DOTQ    FDB     DOCOL
2964         FDB     LIT8
2965         FCB     $22     ascii quote
2966         FDB     STATE,AT,ZBRAN
2967         FDB     DOTQ1-*
2968         FDB     COMPIL,PDOTQ,WORD
2969         FDB     HERE,CAT,ONEP,ALLOT,BRAN
2970         FDB     DOTQ2-*
2971 DOTQ1   FDB     WORD,HERE,COUNT,TYPE
2972 DOTQ2   FDB     SEMIS
2973 *
2974 * ######>> screen 45 <<
2975 * ======>>  126  <<== MACHINE DEPENDENT
2976         FCB     $86
2977         FCC     '?STAC' ; '?STACK'
2978         FCB     $CB
2979         FDB     DOTQ-5
2980 QSTACK  FDB     DOCOL,LIT8
2981         FCB     $12
2982         FDB     PORIG,AT,TWO,SUB,SPAT,LESS,ONE
2983         FDB     QERR
2984 * prints 'empty stack'
2985 *
2986 QSTAC2  FDB     SPAT
2987 * Here, we compare with a value at least 128
2988 * higher than dict. ptr. (DICTPT)
2989         FDB     HERE,LIT8
2990         FCB     $80
2991         FDB     PLUS,LESS,ZBRAN
2992         FDB     QSTAC3-*
2993         FDB     TWO
2994         FDB     QERR
2995 * prints 'full stack'
2996 *
2997 QSTAC3  FDB     SEMIS
2998 *
2999 * ======>>  127  <<     this word's function
3000 *           is done by ?STACK in this version
3001 *       FCB     $85
3002 *       FCC     4,?FREE
3003 *       FCB     $C5
3004 *       FDB     QSTACK-9
3005 *QFREE  FDB     DOCOL,SPAT,HERE,LIT8
3006 *       FCB     $80
3007 *       FDB     PLUS,LESS,TWO,QERR,SEMIS
3008 *
3009 * ######>> screen 46 <<
3010 * ======>>  128  <<
3011         FCB     $86
3012         FCC     'EXPEC' ; 'EXPECT'
3013         FCB     $D4
3014         FDB     QSTACK-9
3015 EXPECT  FDB     DOCOL,OVER,PLUS,OVER,XDO
3016 EXPEC2  FDB     KEY,DUP,LIT8
3017         FCB     $0E
3018         FDB     PORIG,AT,EQUAL,ZBRAN
3019         FDB     EXPEC3-*
3020         FDB     DROP,LIT8
3021         FCB     8       ( backspace character to emit )
3022         FDB     OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
3023         FDB     TOR,SUB,BRAN
3024         FDB     EXPEC6-*
3025 EXPEC3  FDB     DUP,LIT8
3026         FCB     $D      ( carriage return )
3027         FDB     EQUAL,ZBRAN
3028         FDB     EXPEC4-*
3029         FDB     LEAVE,DROP,BL,ZERO,BRAN
3030         FDB     EXPEC5-*
3031 EXPEC4  FDB     DUP
3032 EXPEC5  FDB     I,CSTORE,ZERO,I,ONEP,STORE
3033 EXPEC6  FDB     EMIT,XLOOP
3034         FDB     EXPEC2-*
3035         FDB     DROP
3036         FDB     SEMIS
3037 *
3038 * ======>>  129  <<
3039         FCB     $85
3040         FCC     'QUER'  ; 'QUERY'
3041         FCB     $D9
3042         FDB     EXPECT-9
3043 QUERY   FDB     DOCOL,TIB,AT,COLUMS
3044         FDB     AT,EXPECT,ZERO,IN,STORE
3045         FDB     SEMIS
3046 *
3047 * ======>>  130  <<
3048         FCB     $C1     immediate       < carriage return >
3049         FCB     $80
3050         FDB     QUERY-8
3051 NULL    FDB     DOCOL,BLK,AT,ZBRAN
3052         FDB     NULL2-*
3053         FDB     ONE,BLK,PSTORE
3054         FDB     ZERO,IN,STORE,BLK,AT,BSCR,MOD
3055         FDB     ZEQU
3056 *     check for end of screen
3057         FDB     ZBRAN
3058         FDB     NULL1-*
3059         FDB     QEXEC,FROMR,DROP
3060 NULL1   FDB     BRAN
3061         FDB     NULL3-*
3062 NULL2   FDB     FROMR,DROP
3063 NULL3   FDB     SEMIS
3064 *
3065 * ######>> screen 47 <<
3066 * ======>>  133  <<
3067         FCB     $84
3068         FCC     'FIL'   ; 'FILL'
3069         FCB     $CC
3070         FDB     NULL-4
3071 FILL    FDB     DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
3072         FDB     FROMR,ONE,SUB,CMOVE
3073         FDB     SEMIS
3074 *
3075 * ======>>  134  <<
3076         FCB     $85
3077         FCC     'ERAS'  ; 'ERASE'
3078         FCB     $C5
3079         FDB     FILL-7
3080 ERASE   FDB     DOCOL,ZERO,FILL
3081         FDB     SEMIS
3082 *
3083 * ======>>  135  <<
3084         FCB     $86
3085         FCC     'BLANK' ; 'BLANKS'
3086         FCB     $D3
3087         FDB     ERASE-8
3088 BLANKS  FDB     DOCOL,BL,FILL
3089         FDB     SEMIS
3090 *
3091 * ======>>  136  <<
3092         FCB     $84
3093         FCC     'HOL'   ; 'HOLD'
3094         FCB     $C4
3095         FDB     BLANKS-9
3096 HOLD    FDB     DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
3097         FDB     SEMIS
3098 *
3099 * ======>>  137  <<
3100         FCB     $83
3101         FCC     'PA'    ; 'PAD'
3102         FCB     $C4
3103         FDB     HOLD-7
3104 PAD     FDB     DOCOL,HERE,LIT8
3105         FCB     $44
3106         FDB     PLUS
3107         FDB     SEMIS
3108 *
3109 * ######>> screen 48 <<
3110 * ======>>  138  <<
3111         FCB     $84
3112         FCC     'WOR'   ; 'WORD'
3113         FCB     $C4
3114         FDB     PAD-6
3115 WORD    FDB     DOCOL,BLK,AT,ZBRAN
3116         FDB     WORD2-*
3117         FDB     BLK,AT,BLOCK,BRAN
3118         FDB     WORD3-*
3119 WORD2   FDB     TIB,AT
3120 WORD3   FDB     IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
3121         FCB     34
3122         FDB     BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
3123         FDB     CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
3124         FDB     SEMIS
3125 *
3126 * ######>> screen 49 <<
3127 * ======>>  139  <<
3128         FCB     $88
3129         FCC     '(NUMBER'       ; '(NUMBER)'
3130         FCB     $A9
3131         FDB     WORD-7
3132 PNUMB   FDB     DOCOL
3133 PNUMB2  FDB     ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3134         FDB     PNUMB4-*
3135         FDB     SWAP,BASE,AT,USTAR,DROP,ROT,BASE
3136         FDB     AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3137         FDB     PNUMB3-*
3138         FDB     ONE,DPL,PSTORE
3139 PNUMB3  FDB     FROMR,BRAN
3140         FDB     PNUMB2-*
3141 PNUMB4  FDB     FROMR
3142         FDB     SEMIS
3143 *
3144 * ======>>  140  <<
3145         FCB     $86
3146         FCC     'NUMBE' ; 'NUMBER'
3147         FCB     $D2
3148         FDB     PNUMB-11
3149 NUMB    FDB     DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
3150         FCC     "-"     minus sign
3151         FDB     EQUAL,DUP,TOR,PLUS,LIT,$FFFF
3152 NUMB1   FDB     DPL,STORE,PNUMB,DUP,CAT,BL,SUB
3153         FDB     ZBRAN
3154         FDB     NUMB2-*
3155         FDB     DUP,CAT,LIT8
3156         FCC     "."
3157         FDB     SUB,ZERO,QERR,ZERO,BRAN
3158         FDB     NUMB1-*
3159 NUMB2   FDB     DROP,FROMR,ZBRAN
3160         FDB     NUMB3-*
3161         FDB     DMINUS
3162 NUMB3   FDB     SEMIS
3163 *
3164 * ======>>  141  <<
3165         FCB     $85
3166         FCC     '-FIN'  ; '-FIND'
3167         FCB     $C4
3168         FDB     NUMB-9
3169 DFIND   FDB     DOCOL,BL,WORD,HERE,CONTXT,AT,AT
3170         FDB     PFIND,DUP,ZEQU,ZBRAN
3171         FDB     DFIND2-*
3172         FDB     DROP,HERE,LATEST,PFIND
3173 DFIND2  FDB     SEMIS
3174 *
3175 * ######>> screen 50 <<
3176 * ======>>  142  <<
3177         FCB     $87
3178         FCC     '(ABORT'        ; '(ABORT)'
3179         FCB     $A9
3180         FDB     DFIND-8
3181 PABORT  FDB     DOCOL,ABORT
3182         FDB     SEMIS
3183 *
3184 * ======>>  143  <<
3185         FCB     $85
3186         FCC     'ERRO'  ; 'ERROR'
3187         FCB     $D2
3188         FDB     PABORT-10
3189 ERROR   FDB     DOCOL,WARN,AT,ZLESS
3190         FDB     ZBRAN
3191 * note: WARNING is -1 to abort, 0 to print error #
3192 * and 1 to print error message from disc
3193         FDB     ERROR2-*
3194         FDB     PABORT
3195 ERROR2  FDB     HERE,COUNT,TYPE,PDOTQ
3196         FCB     4,7     ( bell )
3197         FCC     " ? "
3198         FDB     MESS,SPSTOR,IN,AT,BLK,AT,QUIT
3199         FDB     SEMIS
3200 *
3201 * ======>>  144  <<
3202         FCB     $83
3203         FCC     'ID'    ; 'ID.'
3204         FCB     $AE
3205         FDB     ERROR-8
3206 IDDOT   FDB     DOCOL,PAD,LIT8
3207         FCB     32
3208         FDB     LIT8
3209         FCB     $5F     ( underline )
3210         FDB     FILL,DUP,PFA,LFA,OVER,SUB,PAD
3211         FDB     SWAP,CMOVE,PAD,COUNT,LIT8
3212         FCB     31
3213         FDB     AND,TYPE,SPACE
3214         FDB     SEMIS
3215 *
3216 * ######>> screen 51 <<
3217 * ======>>  145  <<
3218         FCB     $86
3219         FCC     'CREAT' ; 'CREATE'
3220         FCB     $C5
3221         FDB     IDDOT-6
3222 CREATE  FDB     DOCOL,DFIND,ZBRAN
3223         FDB     CREAT2-*
3224         FDB     DROP,PDOTQ
3225         FCB     8
3226         FCB     7       ( bel )
3227         FCC     "redef: "
3228         FDB     NFA,IDDOT,LIT8
3229         FCB     4
3230         FDB     MESS,SPACE
3231 CREAT2  FDB     HERE,DUP,CAT,WIDTH,AT,MIN
3232         FDB     ONEP,ALLOT,DUP,LIT8
3233         FCB     $A0
3234         FDB     TOGGLE,HERE,ONE,SUB,LIT8
3235         FCB     $80
3236         FDB     TOGGLE,LATEST,COMMA,CURENT,AT,STORE
3237         FDB     HERE,TWOP,COMMA
3238         FDB     SEMIS
3239 *
3240 * ######>> screen 52 <<
3241 * ======>>  146  <<
3242         FCB     $C9     immediate
3243         FCC     '[COMPILE'      ; '[COMPILE]'
3244         FCB     $DD
3245         FDB     CREATE-9
3246 BCOMP   FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
3247         FDB     SEMIS
3248 *
3249 * ======>>  147  <<
3250         FCB     $C7     immediate
3251         FCC     'LITERA'        ; 'LITERAL'
3252         FCB     $CC
3253         FDB     BCOMP-12
3254 LITER   FDB     DOCOL,STATE,AT,ZBRAN
3255         FDB     LITER2-*
3256         FDB     COMPIL,LIT,COMMA
3257 LITER2  FDB     SEMIS
3258 *
3259 * ======>>  148  <<
3260         FCB     $C8     immediate
3261         FCC     'DLITERA'       ; 'DLITERAL'
3262         FCB     $CC
3263         FDB     LITER-10
3264 DLITER  FDB     DOCOL,STATE,AT,ZBRAN
3265         FDB     DLITE2-*
3266         FDB     SWAP,LITER,LITER
3267 DLITE2  FDB     SEMIS
3268 *
3269 * ######>> screen 53 <<
3270 * ======>>  149  <<
3271         FCB     $89
3272         FCC     'INTERPRE'      ; 'INTERPRET'
3273         FCB     $D4
3274         FDB     DLITER-11
3275 INTERP  FDB     DOCOL
3276 INTER2  FDB     DFIND,ZBRAN
3277         FDB     INTER5-*
3278         FDB     STATE,AT,LESS
3279         FDB     ZBRAN
3280         FDB     INTER3-*
3281         FDB     CFA,COMMA,BRAN
3282         FDB     INTER4-*
3283 INTER3  FDB     CFA,EXEC
3284 INTER4  FDB     BRAN
3285         FDB     INTER7-*
3286 INTER5  FDB     HERE,NUMB,DPL,AT,ONEP,ZBRAN
3287         FDB     INTER6-*
3288         FDB     DLITER,BRAN
3289         FDB     INTER7-*
3290 INTER6  FDB     DROP,LITER
3291 INTER7  FDB     QSTACK,BRAN
3292         FDB     INTER2-*
3293 *       FDB     SEMIS   never executed
3294
3295 *
3296 * ######>> screen 54 <<
3297 * ======>>  150  <<
3298         FCB     $89
3299         FCC     'IMMEDIAT'      ; 'IMMEDIATE'
3300         FCB     $C5
3301         FDB     INTERP-12
3302 IMMED   FDB     DOCOL,LATEST,LIT8
3303         FCB     $40
3304         FDB     TOGGLE
3305         FDB     SEMIS
3306 *
3307 * ======>>  151  <<
3308         FCB     $8A
3309         FCC     'VOCABULAR'     ; 'VOCABULARY'
3310         FCB     $D9
3311         FDB     IMMED-12
3312 VOCAB   FDB     DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
3313         FDB     COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
3314 DOVOC   FDB     TWOP,CONTXT,STORE
3315         FDB     SEMIS
3316 *
3317 * ======>>  152  <<
3318 *
3319 * Note: FORTH does not go here in the rom-able dictionary,
3320 *    since FORTH is a type of variable.
3321 *
3322 *
3323 * ======>>  153  <<
3324         FCB     $8B
3325         FCC     'DEFINITION'    ; 'DEFINITIONS'
3326         FCB     $D3
3327         FDB     VOCAB-13
3328 DEFIN   FDB     DOCOL,CONTXT,AT,CURENT,STORE
3329         FDB     SEMIS
3330 *
3331 * ======>>  154  <<
3332         FCB     $C1     immediate       (
3333         FCB     $A8
3334         FDB     DEFIN-14
3335 PAREN   FDB     DOCOL,LIT8
3336         FCC     ")"
3337         FDB     WORD
3338         FDB     SEMIS
3339 *
3340 * ######>> screen 55 <<
3341 * ======>>  155  <<
3342         FCB     $84
3343         FCC     'QUI'   ; 'QUIT'
3344         FCB     $D4
3345         FDB     PAREN-4
3346 QUIT    FDB     DOCOL,ZERO,BLK,STORE
3347         FDB     LBRAK
3348 *
3349 *  Here is the outer interpretter
3350 *  which gets a line of input, does it, prints " OK"
3351 *  then repeats :
3352 QUIT2   FDB     RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
3353         FDB     ZBRAN
3354         FDB     QUIT3-*
3355         FDB     PDOTQ
3356         FCB     3
3357         FCC     ' OK'   ; ' OK'
3358 QUIT3   FDB     BRAN
3359         FDB     QUIT2-*
3360 *       FDB     SEMIS   ( never executed )
3361 *
3362 * ======>>  156  <<
3363         FCB     $85
3364         FCC     'ABOR'  ; 'ABORT'
3365         FCB     $D4
3366         FDB     QUIT-7
3367 ABORT   FDB     DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
3368         FCB     8
3369         FCC     "Forth-68"
3370         FDB     FORTH,DEFIN
3371         FDB     QUIT
3372 *       FDB     SEMIS   never executed
3373         PAGE
3374 *
3375 * ######>> screen 56 <<
3376 * bootstrap code... moves rom contents to ram :
3377 * ======>>  157  <<
3378         FCB     $84
3379         FCC     'COL'   ; 'COLD'
3380         FCB     $C4
3381         FDB     ABORT-8
3382 COLD    FDB     *+NATWID
3383 CENT    LDS     #REND-1 top of destination
3384         LDX     #ERAM   top of stuff to move
3385 COLD2   LEAX -1,X       ;
3386         LDA 0,X
3387         PSHS A  ; move TASK & FORTH to ram
3388         CMPX    #RAM
3389         BNE     COLD2
3390 *
3391         LDS     #XFENCE-1       put stack at a safe place for now
3392         LDX     COLINT
3393         STX     XCOLUM
3394         LDX     DELINT
3395         STX     XDELAY
3396         LDX     VOCINT
3397         STX     XVOCL
3398         LDX     DPINIT
3399         STX     XDICTP
3400         LDX     FENCIN
3401         STX     XFENCE
3402
3403
3404 WENT    LDS     #XFENCE-1       top of destination
3405         LDX     #FENCIN         top of stuff to move
3406 WARM2   LEAX -1,X       ;
3407         LDA 0,X
3408         PSHS A  ;
3409         CMPX    #SINIT
3410         BNE     WARM2
3411 *
3412         LDS     SINIT
3413         LDX     UPINIT
3414         STX     UP              init user ram pointer
3415         LDX     #ABORT
3416         STX     IP
3417         NOP             Here is a place to jump to special user
3418         NOP             initializations such as I/0 interrups
3419         NOP
3420 *
3421 * For systems with TRACE:
3422         LDX     #00
3423         STX     TRLIM   clear trace mode
3424         LDX     #0
3425         STX     BRKPT   clear breakpoint address
3426         JMP     RPSTOR+2 start the virtual machine running !
3427 *
3428 * Here is the stuff that gets copied to ram :
3429 * at address $140:
3430 *
3431 RAM     FDB     $3000,$3000,0,0
3432
3433 * ======>>  (152)  <<
3434         FCB     $C5     immediate
3435         FCC     'FORT'  ; 'FORTH'
3436         FCB     $C8
3437         FDB     NOOP-7
3438 RFORTH  FDB     DODOES,DOVOC,$81A0,TASK-7
3439         FDB     0
3440         FCC     "(C) Forth Interest Group, 1979"
3441         FCB     $84
3442         FCC     'TAS'   ; 'TASK'
3443         FCB     $CB
3444         FDB     FORTH-8
3445 RTASK   FDB     DOCOL,SEMIS
3446 ERAM    FCC     "David Lion"
3447         PAGE
3448 *
3449 * ######>> screen 57 <<
3450 * ======>>  158  <<
3451         FCB     $84
3452         FCC     'S->'   ; 'S->D'
3453         FCB     $C4
3454         FDB     COLD-7
3455 STOD    FDB     DOCOL,DUP,ZLESS,MINUS
3456         FDB     SEMIS
3457
3458
3459 *
3460 * ======>>  159  <<
3461         FCB     $81     ; *
3462         FCB     $AA
3463         FDB     STOD-7
3464 STAR    FDB     *+NATWID
3465         JSR     [USTAR]
3466         LEAU 2,U        ;
3467         RTS
3468 *       JSR     USTARS
3469 *       LEAS 1,S        ;
3470 *       LEAS 1,S        ;
3471 *       JMP     NEXT
3472 *
3473 * ======>>  160  <<
3474         FCB     $84
3475         FCC     '/MO'   ; '/MOD'
3476         FCB     $C4
3477         FDB     STAR-4
3478 SLMOD   FDB     DOCOL,TOR,STOD,FROMR,USLASH
3479         FDB     SEMIS
3480 *
3481 * ======>>  161  <<
3482         FCB     $81     ; /
3483         FCB     $AF
3484         FDB     SLMOD-7
3485 SLASH   FDB     DOCOL,SLMOD,SWAP,DROP
3486         FDB     SEMIS
3487 *
3488 * ======>>  162  <<
3489         FCB     $83
3490         FCC     'MO'    ; 'MOD'
3491         FCB     $C4
3492         FDB     SLASH-4
3493 MOD     FDB     DOCOL,SLMOD,DROP
3494         FDB     SEMIS
3495 *
3496 * ======>>  163  <<
3497         FCB     $85
3498         FCC     '*/MO'  ; '*/MOD'
3499         FCB     $C4
3500         FDB     MOD-6
3501 SSMOD   FDB     DOCOL,TOR,USTAR,FROMR,USLASH
3502         FDB     SEMIS
3503 *
3504 * ======>>  164  <<
3505         FCB     $82
3506         FCC     '*'     ; '*/'
3507         FCB     $AF
3508         FDB     SSMOD-8
3509 SSLASH  FDB     DOCOL,SSMOD,SWAP,DROP
3510         FDB     SEMIS
3511 *
3512 * ======>>  165  <<
3513         FCB     $85
3514         FCC     'M/MO'  ; 'M/MOD'
3515         FCB     $C4
3516         FDB     SSLASH-5
3517 MSMOD   FDB     DOCOL,TOR,ZERO,R,USLASH
3518         FDB     FROMR,SWAP,TOR,USLASH,FROMR
3519         FDB     SEMIS
3520 *
3521 * ======>>  166  <<
3522         FCB     $83
3523         FCC     'AB'    ; 'ABS'
3524         FCB     $D3
3525         FDB     MSMOD-8
3526 ABS     FDB     DOCOL,DUP,ZLESS,ZBRAN
3527         FDB     ABS2-*
3528         FDB     MINUS
3529 ABS2    FDB     SEMIS
3530 *
3531 * ======>>  167  <<
3532         FCB     $84
3533         FCC     'DAB'   ; 'DABS'
3534         FCB     $D3
3535         FDB     ABS-6
3536 DABS    FDB     DOCOL,DUP,ZLESS,ZBRAN
3537         FDB     DABS2-*
3538         FDB     DMINUS
3539 DABS2   FDB     SEMIS
3540 *
3541 * ######>> screen 58 <<
3542 * Disc primatives :
3543 * ======>>  168  <<
3544         FCB     $83
3545         FCC     'US'    ; 'USE'
3546         FCB     $C5
3547         FDB     DABS-7
3548 USE     FDB     DOCON
3549         FDB     XUSE
3550 * ======>>  169  <<
3551         FCB     $84
3552         FCC     'PRE'   ; 'PREV'
3553         FCB     $D6
3554         FDB     USE-6
3555 PREV    FDB     DOCON
3556         FDB     XPREV
3557 * ======>>  170  <<
3558         FCB     $84
3559         FCC     '+BU'   ; '+BUF'
3560         FCB     $C6
3561         FDB     PREV-7
3562 PBUF    FDB     DOCOL,LIT8
3563         FCB     $84
3564         FDB     PLUS,DUP,LIMIT,EQUAL,ZBRAN
3565         FDB     PBUF2-*
3566         FDB     DROP,FIRST
3567 PBUF2   FDB     DUP,PREV,AT,SUB
3568         FDB     SEMIS
3569 *
3570 * ======>>  171  <<
3571         FCB     $86
3572         FCC     'UPDAT' ; 'UPDATE'
3573         FCB     $C5
3574         FDB     PBUF-7
3575 UPDATE  FDB     DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
3576         FDB     SEMIS
3577 *
3578 * ======>>  172  <<
3579         FCB     $8D
3580         FCC     'EMPTY-BUFFER'  ; 'EMPTY-BUFFERS'
3581         FCB     $D3
3582         FDB     UPDATE-9
3583 MTBUF   FDB     DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
3584         FDB     SEMIS
3585 *
3586 * ======>>  173  <<
3587         FCB     $83
3588         FCC     'DR'    ; 'DR0'
3589         FCB     $B0
3590         FDB     MTBUF-16
3591 DRZERO  FDB     DOCOL,ZERO,OFSET,STORE
3592         FDB     SEMIS
3593 *
3594 * ======>>  174  <<== system dependant word
3595         FCB     $83
3596         FCC     'DR'    ; 'DR1'
3597         FCB     $B1
3598         FDB     DRZERO-6
3599 DRONE   FDB     DOCOL,LIT,$07D0,OFSET,STORE
3600         FDB     SEMIS
3601 *
3602 * ######>> screen 59 <<
3603 * ======>>  175  <<
3604         FCB     $86
3605         FCC     'BUFFE' ; 'BUFFER'
3606         FCB     $D2
3607         FDB     DRONE-6
3608 BUFFER  FDB     DOCOL,USE,AT,DUP,TOR
3609 BUFFR2  FDB     PBUF,ZBRAN
3610         FDB     BUFFR2-*
3611         FDB     USE,STORE,R,AT,ZLESS
3612         FDB     ZBRAN
3613         FDB     BUFFR3-*
3614         FDB     R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
3615 BUFFR3  FDB     R,STORE,R,PREV,STORE,FROMR,TWOP
3616         FDB     SEMIS
3617 *
3618 * ######>> screen 60 <<
3619 * ======>>  176  <<
3620         FCB     $85
3621         FCC     'BLOC'  ; 'BLOCK'
3622         FCB     $CB
3623         FDB     BUFFER-9
3624 BLOCK   FDB     DOCOL,OFSET,AT,PLUS,TOR
3625         FDB     PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
3626         FDB     BLOCK5-*
3627 BLOCK3  FDB     PBUF,ZEQU,ZBRAN
3628         FDB     BLOCK4-*
3629         FDB     DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
3630 BLOCK4  FDB     DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
3631         FDB     BLOCK3-*
3632         FDB     DUP,PREV,STORE
3633 BLOCK5  FDB     FROMR,DROP,TWOP
3634         FDB     SEMIS
3635 *
3636 * ######>> screen 61 <<
3637 * ======>>  177  <<
3638         FCB     $86
3639         FCC     '(LINE' ; '(LINE)'
3640         FCB     $A9
3641         FDB     BLOCK-8
3642 PLINE   FDB     DOCOL,TOR,LIT8
3643         FCB     $40
3644         FDB     BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
3645         FCB     $40
3646         FDB     SEMIS
3647 *
3648 * ======>>  178  <<
3649         FCB     $85
3650         FCC     '.LIN'  ; '.LINE'
3651         FCB     $C5
3652         FDB     PLINE-9
3653 DLINE   FDB     DOCOL,PLINE,DTRAIL,TYPE
3654         FDB     SEMIS
3655 *
3656 * ======>>  179  <<
3657         FCB     $87
3658         FCC     'MESSAG'        ; 'MESSAGE'
3659         FCB     $C5
3660         FDB     DLINE-8
3661 MESS    FDB     DOCOL,WARN,AT,ZBRAN
3662         FDB     MESS3-*
3663         FDB     DDUP,ZBRAN
3664         FDB     MESS3-*
3665         FDB     LIT8
3666         FCB     4
3667         FDB     OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
3668         FDB     MESS4-*
3669 MESS3   FDB     PDOTQ
3670         FCB     6
3671         FCC     'err # '        ; 'err # '
3672         FDB     DOT
3673 MESS4   FDB     SEMIS
3674 *
3675 * ======>>  180  <<
3676         FCB     $84
3677         FCC     'LOA'   ; 'LOAD' :      input:scr #
3678         FCB     $C4
3679         FDB     MESS-10
3680 LOAD    FDB     DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
3681         FDB     BSCR,STAR,BLK,STORE
3682         FDB     INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
3683         FDB     SEMIS
3684 *
3685 * ======>>  181  <<
3686         FCB     $C3
3687         FCC     '--'    ; '-->'
3688         FCB     $BE
3689         FDB     LOAD-7
3690 ARROW   FDB     DOCOL,QLOAD,ZERO,IN,STORE,BSCR
3691         FDB     BLK,AT,OVER,MOD,SUB,BLK,PSTORE
3692         FDB     SEMIS
3693         PAGE
3694 *
3695 *
3696 * ######>> screen 63 <<
3697 *    The next 4 subroutines are machine dependent, and are
3698 *    called by words 13 through 16 in the dictionary.
3699 *
3700 * ======>>  182  << code for EMIT
3701 * output using rom CHROUT: redirectable to printer
3702 PEMIT   PULU    D
3703 PEMITW  TFR     B,A     ; Coco ROM wants it in A.
3704         PSHS    Y,U,DP  ; Save everything important!
3705         CLRB
3706         TFR     B,DP    ; Give the ROM it's direct page.
3707         JSR     [$A002] ; Output the character in A.
3708         PULS    Y,U,DP,PC
3709 * PEMIT STB N   save B
3710 *       STX     N+1     save X
3711 *       LDB ACIAC
3712 *       BITB #2 check ready bit
3713 *       BEQ     PEMIT+4 if not ready for more data
3714 *       STA ACIAD
3715 *       LDX     UP
3716 *       STB IOSTAT-UORIG,X
3717 *       LDB N   recover B & X
3718 *       LDX     N+1
3719 *       RTS             only A register may change
3720 *  PEMIT        JMP     $E1D1   for MIKBUG
3721 *  PEMIT        FCB     $3F,$11,$39     for PROTO
3722 *  PEMIT        JMP     $D286 for Smoke Signal DOS
3723 *
3724 * ======>>  183  << code for KEY
3725 * wait for key from POLCAT
3726 PKEY    PSHS    Y,U,DP
3727         LDA     #$CF    ; a cursor of sorts
3728         CLRB
3729         TFR     B,DP
3730         SETDP   0
3731         LDX     <$88    ; location
3732         LDB     ,X      ; save glyph
3733         STA     ,X
3734 PKEYLP  JSR     [$A000]
3735         BEQ     PKEYLP
3736         STB     ,X      ; restore
3737 PKEYR   CLRB            ; for the break flag
3738         CMPA    #3      ; break key
3739         BNE     PKEYGT
3740         COMB            ; for the break flag
3741 PKEYGT  EXG     A,B
3742         PSHU    D
3743         PULS    Y,U,DP,PC
3744         SETDP IUPDP ******** Check this when I get here again. *********
3745 * PKEY  STB N
3746 *       STX     N+1
3747 *       LDB ACIAC
3748 *       ASRB    ;
3749 *       BCC     PKEY+4  no incoming data yet
3750 *       LDA ACIAD
3751 *       ANDA #$7F       strip parity bit
3752 *       LDX     UP
3753 *       STB IOSTAT+1-UORIG,X
3754 *       LDB N
3755 *       LDX     N+1
3756 *       RTS
3757 *  PKEY JMP     $E1AC   for MIKBUG
3758 *  PKEY FCB     $3F,$14,$39     for PROTO
3759 *  PKEY JMP     $D289 for Smoke Signal DOS
3760 *
3761 * ######>> screen 64 <<
3762 * ======>>  184  << code for ?TERMINAL
3763 * check break key using POLCAT
3764 PQTER   PSHS Y,U,DP
3765         CLRB
3766         TFR B,DP
3767         JSR [$A000]     ; Look but don't wait.
3768         BRA PKEYR
3769 * PQTER LDA ACIAC       Test for 'break'  condition
3770 *       ANDA #$11       mask framing error bit and
3771 *                       input buffer full
3772 *       BEQ     PQTER2
3773 *       LDA ACIAD       clear input buffer
3774 *       LDA #01
3775 * PQTER2        RTS
3776
3777
3778         PAGE
3779 *
3780 * ======>>  185  << code for CR
3781 * For Coco just output a CR.
3782 PCR     LDB #$0D
3783         BRA PEMITW
3784 * PCR   LDA #$D carriage return
3785 *       BSR     PEMIT
3786 *       LDA #$A line feed
3787 *       BSR     PEMIT
3788 *       LDA #$7F        rubout
3789 *       LDX     UP
3790 *       LDB XDELAY+1-UORIG,X
3791 * PCR2  DECB    ;
3792 *       BMI     PQTER2  return if minus
3793 *       PSHS B  ; save counter
3794 *       BSR     PEMIT   print RUBOUTs to delay.....
3795 *       PULS B  ;
3796 *       BRA     PCR2    repeat
3797
3798
3799         PAGE
3800 *
3801 * ######>> screen 66 <<
3802 * ======>>  187  <<
3803         FCB     $85
3804         FCC     '?DIS'  ; '?DISC'
3805         FCB     $C3
3806         FDB     ARROW-6
3807 QDISC   FDB     *+NATWID
3808         JMP     NEXT
3809 *
3810 * ######>> screen 67 <<
3811 * ======>>  189  <<
3812         FCB     $8B
3813         FCC     'BLOCK-WRIT'    ; 'BLOCK-WRITE'
3814         FCB     $C5
3815         FDB     QDISC-8
3816 BWRITE  FDB     *+NATWID
3817         JMP     NEXT
3818 *
3819 * ######>> screen 68 <<
3820 * ======>>  190  <<
3821         FCB     $8A
3822         FCC     'BLOCK-REA'     ; 'BLOCK-READ'
3823         FCB     $C4
3824         FDB     BWRITE-14
3825 BREAD   FDB     *+NATWID
3826         JMP     NEXT
3827 *
3828 *The next 3 words are written to create a substitute for disc
3829 * mass memory,located between $3210 & $3FFF in ram.
3830 * ======>>  190.1  <<
3831         FCB     $82
3832         FCC     'L'     ; 'LO'
3833         FCB     $CF
3834         FDB     BREAD-13
3835 LO      FDB     DOCON
3836         FDB     MEMEND  a system dependent equate at front
3837 *
3838 * ======>>  190.2  <<
3839         FCB     $82
3840         FCC     'H'     ; 'HI'
3841         FCB     $C9
3842         FDB     LO-5
3843 HI      FDB     DOCON
3844         FDB     MEMTOP  ( $3FFF in this version )
3845 *
3846 * ######>> screen 69 <<
3847 * ======>>  191  <<
3848         FCB     $83
3849         FCC     'R/'    ; 'R/W'
3850         FCB     $D7
3851         FDB     HI-5
3852 RW      FDB     DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
3853         FDB     RW2-*
3854         FDB     PDOTQ
3855         FCB     8
3856         FCC     ' Range ?'      ; ' Range ?'
3857         FDB     QUIT
3858 RW2     FDB     FROMR,ZBRAN
3859         FDB     RW3-*
3860         FDB     SWAP
3861 RW3     FDB     BBUF,CMOVE
3862         FDB     SEMIS
3863 *
3864 * ######>> screen 72 <<
3865 * ======>>  192  <<
3866         FCB     $C1     immediate
3867         FCB     $A7     '       ( tick )
3868         FDB     RW-6
3869 TICK    FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
3870         FDB     SEMIS
3871 *
3872 * ======>>  193  <<
3873         FCB     $86
3874         FCC     'FORGE' ; 'FORGET'
3875         FCB     $D4
3876         FDB     TICK-4
3877 FORGET  FDB     DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
3878         FCB     $18
3879         FDB     QERR,TICK,DUP,FENCE,AT,LESS,LIT8
3880         FCB     $15
3881         FDB     QERR,DUP,ZERO,PORIG,GREAT,LIT8
3882         FCB     $15
3883         FDB     QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
3884         FDB     SEMIS
3885 *
3886 * ######>> screen 73 <<
3887 * ======>>  194  <<
3888         FCB     $84
3889         FCC     'BAC'   ; 'BACK'
3890         FCB     $CB
3891         FDB     FORGET-9
3892 BACK    FDB     DOCOL,HERE,SUB,COMMA
3893         FDB     SEMIS
3894 *
3895 * ======>>  195  <<
3896         FCB     $C5
3897         FCC     'BEGI'  ; 'BEGIN'
3898         FCB     $CE
3899         FDB     BACK-7
3900 BEGIN   FDB     DOCOL,QCOMP,HERE,ONE
3901         FDB     SEMIS
3902 *
3903 * ======>>  196  <<
3904         FCB     $C5
3905         FCC     'ENDI'  ; 'ENDIF'
3906         FCB     $C6
3907         FDB     BEGIN-8
3908 ENDIF   FDB     DOCOL,QCOMP,TWO,QPAIRS,HERE
3909         FDB     OVER,SUB,SWAP,STORE
3910         FDB     SEMIS
3911 *
3912 * ======>>  197  <<
3913         FCB     $C4
3914         FCC     'THE'   ; 'THEN'
3915         FCB     $CE
3916         FDB     ENDIF-8
3917 THEN    FDB     DOCOL,ENDIF
3918         FDB     SEMIS
3919 *
3920 * ======>>  198  <<
3921         FCB     $C2
3922         FCC     'D'     ; 'DO'
3923         FCB     $CF
3924         FDB     THEN-7
3925 DO      FDB     DOCOL,COMPIL,XDO,HERE,THREE
3926         FDB     SEMIS
3927 *
3928 * ======>>  199  <<
3929         FCB     $C4
3930         FCC     'LOO'   ; 'LOOP'
3931         FCB     $D0
3932         FDB     DO-5
3933 LOOP    FDB     DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
3934         FDB     SEMIS
3935 *
3936 * ======>>  200  <<
3937         FCB     $C5
3938         FCC     '+LOO'  ; '+LOOP'
3939         FCB     $D0
3940         FDB     LOOP-7
3941 PLOOP   FDB     DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
3942         FDB     SEMIS
3943 *
3944 * ======>>  201  <<
3945         FCB     $C5
3946         FCC     'UNTI'  ; 'UNTIL' :     ( same as END )
3947         FCB     $CC
3948         FDB     PLOOP-8
3949 UNTIL   FDB     DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
3950         FDB     SEMIS
3951 *
3952 * ######>> screen 74 <<
3953 * ======>>  202  <<
3954         FCB     $C3
3955         FCC     'EN'    ; 'END'
3956         FCB     $C4
3957         FDB     UNTIL-8
3958 END     FDB     DOCOL,UNTIL
3959         FDB     SEMIS
3960 *
3961 * ======>>  203  <<
3962         FCB     $C5
3963         FCC     'AGAI'  ; 'AGAIN'
3964         FCB     $CE
3965         FDB     END-6
3966 AGAIN   FDB     DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
3967         FDB     SEMIS
3968 *
3969 * ======>>  204  <<
3970         FCB     $C6
3971         FCC     'REPEA' ; 'REPEAT'
3972         FCB     $D4
3973         FDB     AGAIN-8
3974 REPEAT  FDB     DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
3975         FDB     TWO,SUB,ENDIF
3976         FDB     SEMIS
3977 *
3978 * ======>>  205  <<
3979         FCB     $C2
3980         FCC     'I'     ; 'IF'
3981         FCB     $C6
3982         FDB     REPEAT-9
3983 IF      FDB     DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
3984         FDB     SEMIS
3985 *
3986 * ======>>  206  <<
3987         FCB     $C4
3988         FCC     'ELS'   ; 'ELSE'
3989         FCB     $C5
3990         FDB     IF-5
3991 ELSE    FDB     DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
3992         FDB     ZERO,COMMA,SWAP,TWO,ENDIF,TWO
3993         FDB     SEMIS
3994 *
3995 * ======>>  207  <<
3996         FCB     $C5
3997         FCC     'WHIL'  ; 'WHILE'
3998         FCB     $C5
3999         FDB     ELSE-7
4000 WHILE   FDB     DOCOL,IF,TWOP
4001         FDB     SEMIS
4002 *
4003 * ######>> screen 75 <<
4004 * ======>>  208  <<
4005         FCB     $86
4006         FCC     'SPACE' ; 'SPACES'
4007         FCB     $D3
4008         FDB     WHILE-8
4009 SPACES  FDB     DOCOL,ZERO,MAX,DDUP,ZBRAN
4010         FDB     SPACE3-*
4011         FDB     ZERO,XDO
4012 SPACE2  FDB     SPACE,XLOOP
4013         FDB     SPACE2-*
4014 SPACE3  FDB     SEMIS
4015 *
4016 * ======>>  209  <<
4017         FCB     $82
4018         FCC     '<'     ; '<#'
4019         FCB     $A3
4020         FDB     SPACES-9
4021 BDIGS   FDB     DOCOL,PAD,HLD,STORE
4022         FDB     SEMIS
4023 *
4024 * ======>>  210  <<
4025         FCB     $82
4026         FCC     '#'     ; '#>'
4027         FCB     $BE
4028         FDB     BDIGS-5
4029 EDIGS   FDB     DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
4030         FDB     SEMIS
4031 *
4032 * ======>>  211  <<
4033         FCB     $84
4034         FCC     'SIG'   ; 'SIGN'
4035         FCB     $CE
4036         FDB     EDIGS-5
4037 SIGN    FDB     DOCOL,ROT,ZLESS,ZBRAN
4038         FDB     SIGN2-*
4039         FDB     LIT8
4040         FCC     "-"
4041         FDB     HOLD
4042 SIGN2   FDB     SEMIS
4043 *
4044 * ======>>  212  <<
4045         FCB     $81     #
4046         FCB     $A3
4047         FDB     SIGN-7
4048 DIG     FDB     DOCOL,BASE,AT,MSMOD,ROT,LIT8
4049         FCB     9
4050         FDB     OVER,LESS,ZBRAN
4051         FDB     DIG2-*
4052         FDB     LIT8
4053         FCB     7
4054         FDB     PLUS
4055 DIG2    FDB     LIT8
4056         FCC     "0"     ascii zero
4057         FDB     PLUS,HOLD
4058         FDB     SEMIS
4059 *
4060 * ======>>  213  <<
4061         FCB     $82
4062         FCC     '#'     ; '#S'
4063         FCB     $D3
4064         FDB     DIG-4
4065 DIGS    FDB     DOCOL
4066 DIGS2   FDB     DIG,OVER,OVER,OR,ZEQU,ZBRAN
4067         FDB     DIGS2-*
4068         FDB     SEMIS
4069 *
4070 * ######>> screen 76 <<
4071 * ======>>  214  <<
4072         FCB     $82
4073         FCC     '.'     ; '.R'
4074         FCB     $D2
4075         FDB     DIGS-5
4076 DOTR    FDB     DOCOL,TOR,STOD,FROMR,DDOTR
4077         FDB     SEMIS
4078 *
4079 * ======>>  215  <<
4080         FCB     $83
4081         FCC     'D.'    ; 'D.R'
4082         FCB     $D2
4083         FDB     DOTR-5
4084 DDOTR   FDB     DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
4085         FDB     EDIGS,FROMR,OVER,SUB,SPACES,TYPE
4086         FDB     SEMIS
4087 *
4088 * ======>>  216  <<
4089         FCB     $82
4090         FCC     'D'     ; 'D.'
4091         FCB     $AE
4092         FDB     DDOTR-6
4093 DDOT    FDB     DOCOL,ZERO,DDOTR,SPACE
4094         FDB     SEMIS
4095 *
4096 * ======>>  217  <<
4097         FCB     $81     .
4098         FCB     $AE
4099         FDB     DDOT-5
4100 DOT     FDB     DOCOL,STOD,DDOT
4101         FDB     SEMIS
4102 *
4103 * ======>>  218  <<
4104         FCB     $81     ?
4105         FCB     $BF
4106         FDB     DOT-4
4107 QUEST   FDB     DOCOL,AT,DOT
4108         FDB     SEMIS
4109 *
4110 * ######>> screen 77 <<
4111 * ======>>  219  <<
4112         FCB     $84
4113         FCC     'LIS'   ; 'LIST'
4114         FCB     $D4
4115         FDB     QUEST-4
4116 LIST    FDB     DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
4117         FCB     6
4118         FCC     "SCR # "
4119         FDB     DOT,LIT8
4120         FCB     $10
4121         FDB     ZERO,XDO
4122 LIST2   FDB     CR,I,THREE
4123         FDB     DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
4124         FDB     LIST2-*
4125         FDB     CR
4126         FDB     SEMIS
4127 *
4128 * ======>>  220  <<
4129         FCB     $85
4130         FCC     'INDE'  ; 'INDEX'
4131         FCB     $D8
4132         FDB     LIST-7
4133 INDEX   FDB     DOCOL,CR,ONEP,SWAP,XDO
4134 INDEX2  FDB     CR,I,THREE
4135         FDB     DOTR,SPACE,ZERO,I,DLINE
4136         FDB     QTERM,ZBRAN
4137         FDB     INDEX3-*
4138         FDB     LEAVE
4139 INDEX3  FDB     XLOOP
4140         FDB     INDEX2-*
4141         FDB     SEMIS
4142 *
4143 * ======>>  221  <<
4144         FCB     $85
4145         FCC     'TRIA'  ; 'TRIAD'
4146         FCB     $C4
4147         FDB     INDEX-8
4148 TRIAD   FDB     DOCOL,THREE,SLASH,THREE,STAR
4149         FDB     THREE,OVER,PLUS,SWAP,XDO
4150 TRIAD2  FDB     CR,I
4151         FDB     LIST,QTERM,ZBRAN
4152         FDB     TRIAD3-*
4153         FDB     LEAVE
4154 TRIAD3  FDB     XLOOP
4155         FDB     TRIAD2-*
4156         FDB     CR,LIT8
4157         FCB     $0F
4158         FDB     MESS,CR
4159         FDB     SEMIS
4160 *
4161 * ######>> screen 78 <<
4162 * ======>>  222  <<
4163         FCB     $85
4164         FCC     'VLIS'  ; 'VLIST'
4165         FCB     $D4
4166         FDB     TRIAD-8
4167 VLIST   FDB     DOCOL,LIT8
4168         FCB     $80
4169         FDB     OUT,STORE,CONTXT,AT,AT
4170 VLIST1  FDB     OUT,AT,COLUMS,AT,LIT8
4171         FCB     32
4172         FDB     SUB,GREAT,ZBRAN
4173         FDB     VLIST2-*
4174         FDB     CR,ZERO,OUT,STORE
4175 VLIST2  FDB     DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
4176         FDB     DUP,ZEQU,QTERM,OR,ZBRAN
4177         FDB     VLIST1-*
4178         FDB     DROP
4179         FDB     SEMIS
4180 *
4181 * ======>>  XX  <<
4182         FCB     $84
4183         FCC     'NOO'   ; 'NOOP'
4184         FCB     $D0
4185         FDB     VLIST-8
4186 NOOP    FDB     NEXT    a useful no-op
4187 ZZZZ    FDB     0,0,0,0,0,0,0,0 end of rom program
4188
4189         PAGE
4190 *  These things, up through the lable 'REND', are overwritten
4191 *  at time of cold load and should have the same contents
4192 *  as shown here:
4193 *
4194         FCB     $C5     immediate
4195         FCC     'FORT'  ; 'FORTH'
4196         FCB     $C8
4197         FDB     NOOP-7
4198 FORTH   FDB     DODOES,DOVOC,$81A0,TASK-7
4199         FDB     0
4200 *
4201         FCC     "(C) Forth Interest Group, 1979"
4202
4203         FCB     $84
4204         FCC     'TAS'   ; 'TASK'
4205         FCB     $CB
4206         FDB     FORTH-8
4207 TASK    FDB     DOCOL,SEMIS
4208 *
4209 REND    EQU     *       ( first empty location in dictionary )
4210
4211
4212
4213
4214
4215
4216
4217         PAGE
4218         OPT     L
4219         END