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 BACKSP  FDB     $08     backspace character for editing
 372 UPINIT  FDB     UORIG   initial user area
 373 * UPINIT        FDB     UORIG   initial user area
 374 SINIT   FDB     ISP     ; initial top of data stack
 375 * SINIT FDB     ORIG-$D0        initial top of data stack
 376 RINIT   FDB     IRP     ; initial top of return stack
 377 * RINIT FDB     ORIG-2  initial top of return stack
 378         FDB     ITIB    ; terminal input buffer
 379 *       FDB     ORIG-$D0        terminal input buffer
 380         FDB     31      initial name field width
 381         FDB     0       initial warning mode (0 = no disc)
 382 FENCIN  FDB     REND    initial fence
 383 DPINIT  FDB     REND    cold start value for DICTPT
 384 VOCINT  FDB     FORTH+8
 385 COLINT  FDB     132     initial terminal carriage width
 386 DELINT  FDB     4       initial carriage return delay
 387 ****************************************************
 388 *
 389         PAGE
 390 *
 391 * ######>> screen 13 <<
 392 * These were of questionable use anyway,
 393 * kept here now to satisfy the assembler and show hints.
 394 * They're too much trouble to use with native subroutine call anyway.
 395 * PULABX        PULS A  ; 24 cycles until 'NEXT'
 396 *       PULS B  ;
 397 PULABX  PULU A,B        ; ?? cycles until 'NEXT'
 398 * STABX STA 0,X 16 cycles until 'NEXT'
 399 *       STB 1,X
 400 STABX   STD 0,X ; ?? cycles until 'NEXT'
 401         BRA     NEXT
 402 * GETX  LDA 0,X 18 cycles until 'NEXT'
 403 *       LDB 1,X
 404 GETX    LDD 0,X ?? cycles until 'NEXT'
 405 * PUSHBA        PSHS B  ; 8 cycles until 'NEXT'
 406 *       PSHS A  ;
 407 PUSHBA  PSHU A,B        ; ?? cycles until 'NEXT'
 408
 409
 410 *
 411 * "NEXT" takes ?? cycles if TRACE is removed,
 412 *
 413 * and ?? cycles if trace is present and NOT tracing.
 414 *
 415 * = = = = = = =   t h e   v i r t u a l   m a c h i n e   = = = = =
 416 *                                                                 =
 417 * NEXT itself might just completely go away.
 418 * About the only reason to keep it is to allowing executing a list
 419 * which allows a cheap TRACE routine.
 420 *
 421 * NEXT is a loop which implements the Forth VM.
 422 * It basically cycles through calling the code out of code lists,
 423 * one at a time.
 424 * Using a native CPU return for this uses a few extra cycles per call,
 425 * compared to simply jumping to each definition and jumping back
 426 * to the known beginning of the loop,
 427 * but the loop itself is really only there for convenience.
 428 *
 429 * This implementation uses the native subroutine call,
 430 * to break the wall between Forth code and non-Forth code.
 431 *
 432 * NEXT  LDX     IP
 433 *       LEAX 1,X        ;               pre-increment mode
 434 *       LEAX 1,X        ;
 435 *       STX     IP
 436 NEXT    ; IP is Y, push before using, pull before you come back here.
 437 *
 438 * NEXT2 LDX     0,X     get W which points to CFA of word to be done
 439 NEXT2   LDX     ,Y++    get W which points to CFA of word to be done
 440 * But NEXT2 is too much trouble to use with subroutine threading anyway.
 441 * NEXT3 STX     W
 442 NEXT3   ; W is X until you use X for something else. (TOS points back here.)
 443 * But NEXT3 is too much trouble to use with subroutine threading anyway.
 444 *       LDX     0,X     get VECT which points to executable code
 445 *                                                                 =
 446 * The next instruction could be patched to JMP TRACE              =
 447 * if a TRACE routine is available:                                =
 448 *                                                                 =
 449 *       JMP     0,X
 450         JSR     [,X]    ; Saving the postinc cycles,
 451 *                       ; but X must be bumped NATWID to the parameters.
 452         NOP
 453 *       JMP     TRACE   ( an alternate for the above )
 454 * In other words, with the call and the NOP,
 455 * there is room to patch the call with a JMP to your TRACE
 456 * routine, which you have to provide.
 457         BRA     NEXT
 458 *                                                                 =
 459 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
 460
 461
 462         PAGE
 463 *
 464 * ======>>  1  <<
 465 * ( --- n )
 466 * Pushes the following natural width integer from the instruction stream
 467 * as a literal, or immediate value.
 468 *
 469 *       FDB {OP}
 470 *       FDB {OP}
 471 *       FDB LIT
 472 *       FDB LITERAL-TO-BE-PUSHED
 473 *       FDB {OP}
 474 *
 475 * In native processor code, there should be a better way, use that instead.
 476 * More specifically, DO NOT CALL THIS from assembly language code.
 477 * (Note that there is no compile-only flag in the fig model.)
 478 *
 479 * See (FIND), or PFIND , for layout of the header format.
 480 *
 481         FCB     $83
 482         FCC     'LI'    ; 'LIT' :       NOTE: this is different from LITERAL
 483         FCB     $D4     ; 'T'|'\x80'    ; character code for T, with high bit set.
 484         FDB     0       ; link of zero to terminate dictionary scan
 485 LIT     FDB     *+NATWID        ; Note also that it is meaningless in native code.
 486         LDD     ,Y++
 487         PSHU    A,B
 488         RTS
 489 *       LDX     IP
 490 *       LEAX 1,X        ;
 491 *       LEAX 1,X        ;
 492 *       STX     IP
 493 *       LDA 0,X
 494 *       LDB 1,X
 495 *       JMP     PUSHBA
 496 *
 497 * ######>> screen 14 <<
 498 * ======>>  2  <<
 499 * ( --- n )
 500 * Pushes the following byte from the instruction stream
 501 * as a literal, or immediate value.
 502 *
 503 *       FDB {OP}
 504 *       FDB {OP}
 505 *       FDB LIT8
 506 *       FCB LITERAL-TO-BE-PUSHED
 507 *       FDB {OP}
 508 *
 509 * If this is kept, it should have a header for TRACE to read.
 510 * If the data bus is wider than a byte, you don't want to do this.
 511 * Byte shaving like this is often counter-productive anyway.
 512 * Changing the name to LIT8, hoping that will be more understandable.
 513 * Also, see comments for LIT.
 514 * (Note that there is no compile-only flag in the fig model.)
 515         FCB     $84
 516         FCC     'LIT'   ; 'LIT8' :      NOTE: this is different from LITERAL
 517         FCB     $B8
 518         FDB     LIT-6
 519 LIT8    FDB     *+NATWID         (this was an invisible word, with no header)
 520         LDB     ,Y+     ; This also is meaningless in native code.
 521         CLRA
 522         PSHU    A,B
 523         RTS
 524 *       LDX     IP
 525 *       LEAX 1,X        ;
 526 *       STX     IP
 527 *       CLRA    ;
 528 *       LDB 1,X
 529 *       JMP     PUSHBA
 530 *
 531 * ======>>  3  <<
 532 * ( adr --- )
 533 * Jump to address on stack.  Used by the "outer" interpreter to
 534 * interactively invoke routines.
 535 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
 536         FCB     $87
 537         FCC     'EXECUT'        ; 'EXECUTE'
 538         FCB     $C5
 539         FDB     LIT-7
 540 EXEC    FDB     *+NATWID
 541         PULU    X       ; Gotta have W anyway, just in case.
 542         JMP     [,X]    ; Tail return.
 543 *       TFR S,X ; TSX :
 544 *       LDX     0,X     get code field address (CFA)
 545 *       LEAS 1,S        ;               pop stack
 546 *       LEAS 1,S        ;
 547 *       JMP     NEXT3
 548 *
 549 * ######>> screen 15 <<
 550 * ======>>  4  <<
 551 * ( --- )                                                 C
 552 * Add the following word from the instruction stream to the
 553 * instruction pointer (Y++).  Causes a program branch in Forth code stream.
 554 *
 555 * In native processor code, there should be a better way, use that instead.
 556 * More specifically, DO NOT CALL THIS from assembly language code.
 557 * This is only for Forth code stream.
 558 * Also, see comments for LIT.
 559         FCB     $86
 560         FCC     'BRANC' ; 'BRANCH'
 561         FCB     $C8
 562         FDB     EXEC-10
 563 BRAN    FDB     ZBYES   ; Go steal code in ZBRANCH
 564
 565 * Moving code around to optimize the branch taking case in 0BRANCH.
 566 ZBNO    LEAY    NATWID,Y ;      No branch.
 567         RTS
 568 * ======>>  5  <<
 569 * ( f --- )                                               C
 570 * BRANCH if flag is zero.
 571 *
 572 * In native processor code, there should be a better way, use that instead.
 573 * More specifically, DO NOT CALL THIS from assembly language code.
 574 * This is only for Forth code stream.
 575 * Also, see comments for LIT.
 576         FCB     $87
 577         FCC     '0BRANC'        ; '0BRANCH'
 578         FCB     $C8
 579         FDB     BRAN-9
 580 ZBRAN   FDB     *+NATWID
 581         LDD     ,U++
 582         BNE     ZBNO
 583 ZBYES   LDD     ,Y++
 584         LEAY    D,Y     ; IP is postinc
 585         RTS
 586 *       PULS A  ;
 587 *       PULS B  ;
 588 *       PSHS B  ; ** emulating ABA:
 589 *       ADDA ,S+        ;
 590 *       BNE     ZBNO
 591 *       BCS     ZBNO
 592 * ZBYES LDX     IP      Note: code is shared with BRANCH, (+LOOP), (LOOP)
 593 *       LDB 3,X
 594 *       LDA 2,X
 595 *       ADDB IP+1
 596 *       ADCA IP
 597 *       STB IP+1
 598 *       STA IP
 599 *       JMP     NEXT
 600 * ZBNO  LDX     IP      no branch. This code is shared with (+LOOP), (LOOP).
 601 *       LEAX 1,X        ;               jump over branch delta
 602 *       LEAX 1,X        ;
 603 *       STX     IP
 604 *       JMP     NEXT
 605 *
 606 * ######>> screen 16 <<
 607 * ======>>  6  <<
 608 * ( --- )         ( limit index *** limit index+1)        C
 609 *                 ( limit index *** )
 610 * Counting loop primitive.  The counter and limit are the top two
 611 * words on the return stack.  If the updated index/counter does
 612 * not exceed the limit, a branch occurs.  If it does, the branch
 613 * does not occur, and the index and limit are dropped from the
 614 * return stack.
 615 *
 616 * In native processor code, there should be a better way, use that instead.
 617 * More specifically, DO NOT CALL THIS from assembly language code.
 618 * This is only for Forth code stream.
 619 * Also, see comments for LIT.
 620         FCB     $86
 621         FCC     '(LOOP' ; '(LOOP)'
 622         FCB     $A9
 623         FDB     ZBRAN-10
 624 XLOOP   FDB     *+NATWID
 625         LDD     #1      ; Borrowing from BIF-6809.
 626 XLOOPA  ADDD    NATWID,S        ; Dodge the return address.
 627         STD     NATWID,S
 628         SUBD    2*NATWID,S
 629         BLT     ZBYES   ; signed
 630 XLOOPN  LEAY    NATWID,Y
 631         LDX     ,S      ; synthetic return
 632         LEAS    3*NATWID,S      ; Clean up the index and limit.
 633         JMP     ,X
 634 *       CLRA    ;
 635 *       LDB #1  get set to increment counter by 1 (Clears N.)
 636 *       BRA     XPLOP2  go steal other guy's code!
 637 *
 638 * ======>>  7  <<
 639 * ( n --- )       ( limit index *** limit index+n )       C
 640 *                 ( limit index *** )
 641 * Loop with a variable increment.  Terminates when the index
 642 * crosses the boundary from one below the limit to the limit.  A
 643 * positive n will cause termination if the result index equals the
 644 * limit.  A negative n must cause the index to become less than
 645 * the limit to cause loop termination.
 646 *
 647 * Note that the end conditions are not symmetric around zero.
 648 *
 649 * In native processor code, there should be a better way, use that instead.
 650 * More specifically, DO NOT CALL THIS from assembly language code.
 651 * This is only for Forth code stream.
 652 * Also, see comments for LIT.
 653         FCB     $87
 654         FCC     '(+LOOP'        ; '(+LOOP)'
 655         FCB     $A9
 656         FDB     XLOOP-9
 657 XPLOOP  FDB     *+NATWID        ; Borrowing from BIF-6809.
 658         LDD     ,U++            ; inc val
 659         BPL     XLOOPA          ; Steal plain loop code for forward count.
 660         ADDD    NATWID,S                ; Dodge the return address
 661         STD     NATWID,S
 662         SUBD    2*NATWID,S
 663         BGT     ZBYES           ; signed
 664         BRA     XLOOPN          ; This path is less time-sensitive.
 665 *
 666 * This should work, but I want to use tested code.
 667 *       PULU    A,B     ; Get the increment.
 668 * XPLOP2        PULS    X       ; Pre-clear the return stack.
 669 *       PSHU    A       ; Save the direction in high bit.
 670 *       ADDD    ,S      ; Count.
 671 *       STD     ,S      ; Update.
 672 *       SUBD    NATWID,S        ; Check limit.
 673 **
 674 ** I think this should work:
 675 *       EORA    ,U+     ; dir < 0 and (count - limit) >= 0
 676 *       BPL     XPLONO  ; or dir >= 0 and (count - limit) < 0
 677 *       LDD     ,Y++
 678 *       LEAY    D,Y     ; IP is postinc
 679 *       JMP     ,X
 680 * XPLONO        LEAS    2*NATWID,S
 681 *       JMP     ,X      ; synthetic return
 682 *
 683 * This definitely should work:
 684 *       TST     ,U+     ; Get the sign
 685 *       BPL     XPLOF   ;
 686 *       CMPD    NATWID,S
 687 *       BMI     XPLONO
 688 * XPLOYE        LDD     ,Y++
 689 *       LEAY    D,Y     ; IP is postinc
 690 *       JMP     ,X
 691 * XPLOF CMPD    NATWID,S
 692 *       BMI     XPLOYE
 693 * XPLONO        LEAS    2*NATWID,S
 694 *       JMP     ,X      ; synthetic return
 695 *
 696 * 6800 Probably could have used the exclusive-or method, too.:
 697 *       PULS A  ; get increment
 698 *       PULS B  ;
 699 * XPLOP2        TSTA    ;
 700 *       BPL     XPLOF   forward looping
 701 *       BSR     XPLOPS
 702 *       ORCC #$01       ; SEC :
 703 *       SBCB 5,X
 704 *       SBCA 4,X
 705 *       BPL     ZBYES
 706 *       BRA     XPLONO  fall through
 707 *
 708 * the subroutine :
 709 * XPLOPS        LDX     RP
 710 *       ADDB 3,X        add it to counter
 711 *       ADCA 2,X
 712 *       STB 3,X store new counter value
 713 *       STA 2,X
 714 *       RTS
 715 *
 716 * XPLOF BSR     XPLOPS
 717 *       SUBB 5,X
 718 *       SBCA 4,X
 719 *       BMI     ZBYES
 720 *
 721 * XPLONO        LEAX 1,X        ;               done, don't branch back
 722 *       LEAX 1,X        ;
 723 *       LEAX 1,X        ;
 724 *       LEAX 1,X        ;
 725 *       STX     RP
 726 *       BRA     ZBNO    use ZBRAN to skip over unused delta
 727 *
 728 * ######>> screen 17 <<
 729 * ======>>  8  <<
 730 * ( limit index --- )     ( *** limit index )
 731 * Move the loop parameters to the return stack.  Synonym for D>R.
 732         FCB     $84
 733         FCC     '(DO'   ; '(DO)'
 734         FCB     $A9
 735         FDB     XPLOOP-10
 736 XDO     FDB     *+NATWID        This is the RUNTIME DO, not the COMPILING DO
 737         LDX     ,S      ; Save the return address.
 738         PULU    A,B
 739         PSHS    A,B
 740         PULU    A,B     ; Maintain order.
 741         STD     NATWID,S
 742         JMP     ,X      ; synthetic return
 743 *
 744 *       LDX     RP
 745 *       LEAX -1,X       ;
 746 *       LEAX -1,X       ;
 747 *       LEAX -1,X       ;
 748 *       LEAX -1,X       ;
 749 *       STX     RP
 750 *       PULS A  ;
 751 *       PULS B  ;
 752 *       STA 2,X
 753 *       STB 3,X
 754 *       PULS A  ;
 755 *       PULS B  ;
 756 *       STA 4,X
 757 *       STB 5,X
 758 *       JMP     NEXT
 759 *
 760 * ======>>  9  <<
 761 * ( --- index )           ( limit index *** limit index )
 762 * Copy the loop index from the return stack.  Synonym for R.
 763         FCB     $81     I
 764         FCB     $C9
 765         FDB     XDO-7
 766 I       FDB     *+NATWID
 767         LDD     NATWID,S        ; Dodge return address.
 768         PSHU    A,B
 769         RTS
 770 *       LDX     RP
 771 *       LEAX 1,X        ;
 772 *       LEAX 1,X        ;
 773 *       JMP     GETX
 774 *
 775 * ######>> screen 18 <<
 776 * ======>>  10  <<
 777 * ( c base --- false )
 778 * ( c base --- n true )
 779 * Translate C in base, yielding a translation valid flag.  If the
 780 * translation is not valid in the specified base, only the false
 781 * flag is returned.
 782         FCB     $85
 783         FCC     'DIGI'  ; 'DIGIT'
 784         FCB     $D4
 785         FDB     I-4
 786 DIGIT   FDB     *+NATWID        NOTE: legal input range is 0-9, A-Z
 787         LDD     NATWID,U        ; Check the whole thing.
 788         SUBD    #$30    ; ascii zero
 789         BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
 790         CMPD    #$A
 791         BMI     DIGIT0  IF '9' OR LESS
 792         CMPD    #$11
 793         BMI     DIGIT2  if less than 'A'
 794         CMPD    #$2B
 795         BPL     DIGIT2  if greater than 'Z'
 796         SUBD    #7      translate 'A' thru 'F'
 797 DIGIT0  CMPD    ,U      ; Check the base.
 798         BPL     DIGIT2  if not less than the base
 799         STD     NATWID,U        ; Store converted digit. (High byte known zero.)
 800         LDD     #1      ; set valid flag
 801 DIGIT1  STD     ,U      ; store the flag
 802         RTS     NEXT
 803 DIGIT2  LDD     #0      ; set not valid flag
 804         LEAU    NATWID,U        ; pop base
 805         BRA     DIGIT1
 806 *       TFR S,X ; TSX :
 807 *       LDA 3,X
 808 *       SUBA #$30       ascii zero
 809 *       BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
 810 *       CMPA #$A
 811 *       BMI     DIGIT0  IF '9' OR LESS
 812 *       CMPA #$11
 813 *       BMI     DIGIT2  if less than 'A'
 814 *       CMPA #$2B
 815 *       BPL     DIGIT2  if greater than 'Z'
 816 *       SUBA #7 translate 'A' thru 'F'
 817 * DIGIT0        CMPA 1,X
 818 *       BPL     DIGIT2  if not less than the base
 819 *       LDB #1  set flag
 820 *       STA 3,X store digit
 821 * DIGIT1        STB 1,X store the flag
 822 *       JMP     NEXT
 823 * DIGIT2        CLRB    ;
 824 *       LEAS 1,S        ;
 825 *       LEAS 1,S        ;       pop bottom number
 826 *       TFR S,X ; TSX :
 827 *       STB 0,X make sure both bytes are 00
 828 *       BRA     DIGIT1
 829 *
 830 * ######>> screen 19 <<
 831 *
 832 * The word definition format in the dictionary:
 833 *
 834 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
 835 *
 836 * NFA (name field address):
 837 * char-count + $80      Length of symbol name, flagged with high bit set.
 838 * char 1                Characters of symbol name.
 839 * char 2
 840 * ...
 841 * char n  + $80      symbol termination flag (char set < 128 code points)
 842 * LFA (link field address):
 843 * link high byte \___pointer to previous word in list
 844 * link low  byte /   -- Combined allocation/dictionary list. --
 845 * CFA (code field address):
 846 * CFA  high byte \___pointer to native CPU machine code
 847 * CFA  low  byte /   -- Consider this the characteristic code. --
 848 * PFA (parameter field address):
 849 * parameter fields   -- Machine code for low-level native machine CPU code,
 850 *    "                  instruction list for high-level Forth code,
 851 *    "                  constant data for constants, pointers to per task variables,
 852 *    "                  space for variables, for global variables, etc.
 853 *
 854 * In the case of native CPU machine code, the address at CFA will be PFA.
 855
 856 * Definition attributes:
 857 FIMMED  EQU     $40     ; Immediate word flag.
 858 FSMUDG  EQU     $20     ; Smudged => definition not ready.
 859 CTMASK  EQU     ($FF&(^($80|FIMMED)))   ; For unmasking the length byte.
 860 * Note that the SMUDGE bit is not masked out.
 861 *
 862 * But we really want more (Thinking for a new model, need one more byte):
 863 * FCOMPI        EQU     $10     ; Compile-time-only.
 864 * FASSEM        EQU     $08     ; Assembly-language code only.
 865 * F4THLV        EQU     $04     ; Must not be called from assembly language code.
 866 * These would require some significant adjustments to the model.
 867 * We also want to put the low-level VM stuff in its own vocabulary.
 868 *
 869 * ======>>  11  <<
 870 * (FIND)  ( name vocptr --- locptr length true )
 871 *         ( name vocptr --- false )
 872 * Search vocabulary for a symbol called name.
 873 * name is a pointer to a high-bit bracket string with length head.
 874 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
 875 * in the vocabulary to be searched.
 876 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
 877         FCB     $86
 878         FCC     '(FIND' ; '(FIND)'
 879         FCB     $A9
 880         FDB     DIGIT-8
 881 PFIND   FDB     *+NATWID
 882         PSHS    Y       ; Have to track two pointers.
 883 * Use the stack and registers instead of temp area N.
 884 PA0     EQU     NATWID  ; pointer to the length byte of name being searched against
 885 PD      EQU     0       ; pointer to NFA of dict word being checked
 886 *
 887         LDX     PD,U    ; Start in on the vocabulary (NFA).
 888 PFNDLP  LDY     PA0,U   ; Point to the name to check against.
 889         LDB     ,X+     ; get dict name length byte
 890         TFR     B,A     ; Save it in case it matches.
 891         ANDB    #CTMASK
 892         CMPB    ,Y+     ; Compare lengths
 893         BNE     PFNDUN
 894 PFNDBR  LDB     ,X+
 895         TSTB    ;       ; Is high bit of character in dictionary entry set?
 896         BPL     PFNDCH
 897         ANDB    #$7F    ; Clear high bit from dictionary.
 898         CMPB    ,Y+     ; Compare "last" characters.
 899         BEQ     FOUND   ; Matches even if dictionary actual length is shorter.
 900 PFNDLN  LDX     ,X++    ; Get previous link in vocabulary.
 901         BNE     PFNDLP  ; Continue if link not=0
 902 *
 903 *       not found :
 904         LEAU    NATWID,U        ; Return only false flag.
 905         LDD     #0
 906         STD     ,U
 907         PULS    Y,PC
 908 *
 909 PFNDCH  CMPB    ,Y+     ; Compare characters.
 910         BEQ     PFNDBR
 911 PFNDUN
 912 PFNDSC  LDB     ,X+     ; scan forward to end of this name in dictionary
 913         BPL     PFNDSC
 914         BRA     PFNDLN
 915 *
 916 *       found :
 917 *
 918 FOUND   LEAX    2*NATWID,X
 919         STX     NATWID,U
 920         TFR     A,B
 921         CLRA
 922         STD     ,U
 923         LDB     #1
 924         PSHU    A,B
 925         PULS    Y,PC
 926 *
 927 * 6800 model:
 928 *       NOP     ; Probably leftovers from a debugging session.
 929 *       NOP
 930 * PD    EQU     N       ptr to dict word being checked
 931 * PA0   EQU     N+2
 932 * PA    EQU     N+4
 933 * PC    EQU     N+6
 934 *       LDX     #PD
 935 *       LDB #4
 936 * PFIND0        PULS A  ; loop to get arguments
 937 *       STA 0,X
 938 *       LEAX 1,X        ;
 939 *       DECB    ;
 940 *       BNE     PFIND0
 941 *
 942 *       LDX     PD
 943 * PFNDLP        LDB 0,X get count dict count
 944 *       STB PC
 945 *       ANDB #$3F
 946 *       LEAX 1,X        ;
 947 *       STX     PD      update PD
 948 *       LDX     PA0
 949 *       LDA 0,X get count from arg
 950 *       LEAX 1,X        ;
 951 *       STX     PA      intialize PA
 952 *       PSHS B  ; ** emulating CBA:
 953 *       CMPA ,S+        ;               compare lengths
 954 *       BNE     PFNDUN
 955 * PFNDBR        LDX     PA
 956 *       LDA 0,X
 957 *       LEAX 1,X        ;
 958 *       STX     PA
 959 *       LDX     PD
 960 *       LDB 0,X
 961 *       LEAX 1,X        ;
 962 *       STX     PD
 963 *       TSTB    ;               is dict entry neg. ?
 964 *       BPL     PFNDCH
 965 *       ANDB #$7F       clear sign
 966 *       PSHS B  ; ** emulating CBA:
 967 *       CMPA ,S+        ;
 968 *       BEQ     FOUND
 969 * PFNDLN        LDX     0,X     get new link
 970 *       BNE     PFNDLP  continue if link not=0
 971 *
 972 *       not found :
 973 *
 974 *       CLRA    ;
 975 *       CLRB    ;
 976 *       JMP     PUSHBA
 977 * PFNDCH        PSHS B  ; ** emulating CBA:
 978 *       CMPA ,S+        ;
 979 *       BEQ     PFNDBR
 980 * PFNDUN        LDX     PD
 981 * PFNDSC        LDB 0,X scan forward to end of this name
 982 *       LEAX 1,X        ;
 983 *       BPL     PFNDSC
 984 *       BRA     PFNDLN
 985 *
 986 *       found :
 987 *
 988 * FOUND LDA PD  compute CFA
 989 *       LDB PD+1
 990 *       ADDB #4
 991 *       ADCA #0
 992 *       PSHS B  ;
 993 *       PSHS A  ;
 994 *       LDA PC
 995 *       PSHS A  ;
 996 *       CLRA    ;
 997 *       PSHS A  ;
 998 *       LDB #1
 999 *       JMP     PUSHBA
1000 *
1001 *       PSHS A  ; Left over from a stray copy-paste, I guess.
1002 *       CLRA    ;
1003 *       PSHS A  ;
1004 *       LDB #1
1005 *       JMP     PUSHBA
1006 *
1007 * ######>> screen 20 <<
1008 * ======>>  12  <<
1009 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
1010 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
1011 * ( buffer ch --- buffer nuloffset onepast scancount )
1012 * Scan buffer for a symbol delimited by ch or ASCII NUL,
1013 * return the length of the buffer region scanned,
1014 * the offset to the trailing delimiter,
1015 * and the offset of the first character of the symbol.
1016 * Leave the buffer on the stack.
1017 * Scancount is also offset to first character not yet looked at.
1018 * If no symbol in buffer, scancount and symboloffset point to NUL
1019 * and delimiteroffset points one beyond for some reason.
1020 * On trailing NUL, delimiteroffset == scancount.
1021 * (Buffer is the address of the buffer array to scan.)
1022 * (This is a bit too tricky, really.)
1023         FCB     $87
1024         FCC     'ENCLOS'        ; 'ENCLOSE'
1025         FCB     $C5
1026         FDB     PFIND-9
1027 ENCLOS  FDB     *+NATWID
1028         LDA     1,U     ; Delimiter character to match against in A.
1029         LDX     NATWID,U        ; Buffer to scan in.
1030         CLRB            ; Initialize offset. (Buffer < 256 wide!)
1031 *       Scan to a non-delimiter or a NUL
1032 ENCDEL  TST     B,X     ; NUL ?
1033         BEQ     ENCNUL
1034         CMPA    B,X     ; Delimiter?
1035         BNE     ENC1ST
1036         INCB            ; count character
1037         BRA     ENCDEL
1038 *       Found first character. Save the offset.
1039 ENC1ST  STB     1,U     ; Found first non-delimiter character --
1040         CLR     ,U      ; store the count, zero high byte.
1041 *       Scan to a delimiter or a NUL
1042 ENCSYM  TST     B,X     ; NUL ?
1043         BEQ     ENC0TR
1044         CMPA    B,X     ; delimiter?
1045         BEQ     ENCEND
1046         INCB
1047         BRA     ENCSYM
1048 *       Found end of symbol. Push offset to delimiter found.
1049 ENCEND  CLRA            ; high byte -- buffer < 255 wide!
1050         PSHU    A,B     ; Offset to seen delimiter.
1051 *       Advance and push address of next character to check.
1052         ADDD    #1      ; In case offset was 255.
1053         PSHU    A,B
1054         RTS
1055 *       Found NUL before non-delimiter, therefore there is no word
1056 ENCNUL  CLRA            ; high byte -- buffer < 255 wide!
1057         STD     ,U      ; offset to NUL.
1058         ADDD    #1      ; For some reason, point after NUL.
1059         PSHU    A,B     ;
1060         SUBD    #1      ; Next is not passed NUL.
1061         PSHU    A,B     ; Stealing code will save only one byte.
1062         RTS
1063 *       Found NUL following the word instead of delimiter.
1064 ENC0TR  PSHU    A,B     ; Save offset to first after symbol (NUL)
1065         PSHU    A,B     ; and count scanned.
1066         RTS
1067 * NOTE :
1068 * FC means offset (bytes) to First Character of next word
1069 * EW  "     "   to End of Word
1070 * NC  "     "   to Next Character to start next enclose at
1071 * ENCLOS        FDB     *+NATWID
1072 *       LEAS 1,S        ;
1073 *       PULS B  ; now, get the low byte, for an 8-bit delimiter
1074 *       TFR S,X ; TSX :
1075 *       LDX     0,X
1076 *       CLR N
1077 * *     wait for a non-delimiter or a NUL
1078 * ENCDEL        LDA 0,X
1079 *       BEQ     ENCNUL
1080 *       PSHS B  ; ** emulating CBA:
1081 *       CMPA ,S+        ;               CHECK FOR DELIM
1082 *       BNE     ENC1ST
1083 *       LEAX 1,X        ;
1084 *       INC N
1085 *       BRA     ENCDEL
1086 * *     found first character. Push FC
1087 * ENC1ST        LDA N   found first char.
1088 *       PSHS A  ;
1089 *       CLRA    ;
1090 *       PSHS A  ;
1091 *       wait for a delimiter or a NUL
1092 * ENCSYM        LDA 0,X
1093 *       BEQ     ENC0TR
1094 *       PSHS B  ; ** emulating CBA:
1095 *       CMPA ,S+        ;               ckech for delim.
1096 *       BEQ     ENCEND
1097 *       LEAX 1,X        ;
1098 *       INC N
1099 *       BRA     ENCSYM
1100 * *     found EW. Push it
1101 * ENCEND        LDB N
1102 *       CLRA    ;
1103 *       PSHS B  ;
1104 *       PSHS A  ;
1105 * *     advance and push NC
1106 *       INCB    ;
1107 *       JMP     PUSHBA
1108 *       found NUL before non-delimiter, therefore there is no word
1109 * ENCNUL        LDB N   found NUL
1110 *       PSHS B  ;
1111 *       PSHS A  ;
1112 *       INCB    ;
1113 *       BRA     ENC0TR+2        ; ********** POTENTIAL BUG HERE *******
1114 * ******** Should use labels in case opcodes change! ********
1115 *       found NUL following the word instead of SPACE
1116 * ENC0TR        LDB N
1117 *       PSHS B  ; save EW
1118 *       PSHS A  ;
1119 * ENCL8 LDB N   save NC
1120 *       JMP     PUSHBA
1121
1122         PAGE
1123 *
1124 * ######>> screen 21 <<
1125 * The next 4 words call system dependant I/O routines
1126 * which are listed after word "-->" ( lable: "arrow" )
1127 * in the dictionary.
1128 *
1129 * ======>>  13  <<
1130 * ( c --- )
1131 * Write c to the output device (screen or printer).
1132 * ROM Uses the ECB device number at address $6F,
1133 * -2 is printer, 0 is screen.
1134         FCB     $84
1135         FCC     'EMI'   ; 'EMIT'
1136         FCB     $D4
1137         FDB     ENCLOS-10
1138 EMIT    FDB     *+NATWID
1139         LBSR    PEMIT   ; PEMIT handles the stack.
1140         INC     <XOUT+1
1141         BNE     EMITDN
1142         INC     <XOUT
1143 EMITDN  RTS
1144 *       PULS A  ;
1145 *       PULS A  ;
1146 *       JSR     PEMIT
1147 *       LDX     UP
1148 *       INC XOUT+1-UORIG,X
1149 *       BNE *+4 ;
1150 *       ****WARNING**** HARD OFFSET: *+4 ****
1151 *       INC XOUT-UORIG,X
1152 *       JMP     NEXT
1153 *
1154 * ======>>  14  <<
1155 * ( --- c )
1156 * ( --- BREAK )
1157 * Wait for a key from the keyboard.
1158 * If the key is BREAK, set the high byte (result $FF03).
1159         FCB     $83
1160         FCC     'KE'    ; 'KEY'
1161         FCB     $D9
1162         FDB     EMIT-7
1163 KEY     FDB     *+NATWID
1164         LBSR    PKEY    ; PKEY handles the stack.
1165         RTS
1166 *       JSR     PKEY
1167 *       PSHS A  ;
1168 *       CLRA    ;
1169 *       PSHS A  ;
1170 *       JMP     NEXT
1171 *
1172 * ======>>  15  <<
1173 * ( --- f )
1174 * Scan keyboard, but do not wait.
1175 * Return 0 if no key,
1176 * BREAK ($ff03) if BREAK is pressed,
1177 * or key currently pressed.
1178         FCB     $89
1179         FCC     '?TERMINA'      ; '?TERMINAL'
1180         FCB     $CC
1181         FDB     KEY-6
1182 QTERM   FDB     *+NATWID
1183         LBSR    PQTER   ; PQTER handles the stack.
1184         RTS
1185 *       JSR     PQTER
1186 *       CLRB    ;
1187 *       JMP     PUSHBA  stack the flag
1188 *
1189 * ======>>  16  <<
1190 * ( --- )
1191 * EMIT a Carriage Return (ASCII CR).
1192         FCB     $82
1193         FCC     'C'     ; 'CR'
1194         FCB     $D2
1195         FDB     QTERM-12
1196 CR      FDB     *+NATWID
1197         LBSR    PCR     ; PCR handles the stack.
1198         RTS
1199 *       JSR     PCR
1200 *       JMP     NEXT
1201 *
1202 * ######>> screen 22 <<
1203 * ======>>  17  <<
1204 * ( source target count --- )
1205 * Copy/move count bytes from source to target.
1206 * Moves ascending addresses,
1207 * so that overlapping only works if the source is above the destination.
1208         FCB     $85
1209         FCC     'CMOV'  ; 'CMOVE' :     source, destination, count
1210         FCB     $C5
1211         FDB     CR-5
1212 CMOVE   FDB     *+NATWID
1213 * One way:              ; takes ( 37+17*count+9*(count/256) cycles )
1214         PSHS    Y       ; #2~7 ; Gotta have our pointers.
1215         PULU    D,X,Y   ; #2~11
1216         PSHS    A       ; #2~6 ; Gotta have our pointers.
1217         BRA     CMOVLE  ; #2~3
1218 CMOVLP
1219         LDA     ,Y+     ; #2~6
1220         STA     ,X+     ; #2~6
1221 CMOVLE
1222         SUBB    #1      ; #2~2
1223         BCC     CMOVLP  ; #2~3
1224         DEC     ,S      ; #2=6
1225         BPL     CMOVLP  ; #2~3
1226         PULS    A,Y,PC  ; #2~10
1227 * Another way           ; takes ( 42+17*count+9*(count/256) cycles )
1228 *       LDD #0          ; #3~3
1229 *       SUBD ,U++       ; #2~9 ; invert the count
1230 *       PSHS A,Y        ; #2~8
1231 *       PULU X,Y        ; #2~9
1232 *       BEQ CMOVEX      ; #2~3
1233 * CMOVEL
1234 *       LDA ,Y+         ; #2~6
1235 *       STA ,X+         ; #2~6
1236 *       INCB            ; #1~2
1237 *       BNE CMOVEL      ; #2~3
1238 *       INC ,S          ; #2~6
1239 *       BNE CMOVEL      ; #2~3
1240 * CMOVEX
1241 *       PULS A,Y,PC     ; #2~10
1242 * Yet another way               ; takes ( 37+29*count cycles )
1243 *       PSHS    Y       ; #2~7
1244 *       LDX     NATWID,U        ; #2~6
1245 *       LDY     NATWID,U        ; #3~7
1246 *       BRA     CMOVLE  ; #2~3
1247 * CMOVLP
1248 *       LDA     ,Y+     ; #2~6
1249 *       STA     ,X+     ; #2~6
1250 * CMOVLE
1251 *       LDD     ,U      ; #2~5
1252 *       SUBD    #1      ; #3~4
1253 *       STD     ,U      ; #2~5
1254 *       BPL     CMOVLP  ; #2~3
1255 *       LEAU    3*NATWID,U      ; #2~5
1256 *       PULS    Y,PC    ; #2~9
1257 * Yet another way               ; takes ( 44+24*odd+33*count/2 cycles )
1258 *       PSHS    Y       ; #2~7
1259 *       LDX     NATWID,U        ; #2~6
1260 *       LDY     2*NATWID,U      ; #3~7
1261 *       LDD     ,U      ; #2~5
1262 *       BITB    #1      ; #2~2
1263 *       BEQ     CMOVLE  ; #2~3
1264 *       SUBD    #1      ; #3~4
1265 *       STD     ,U      ; #2~5
1266 *       LDA     ,Y+     ; #2~6
1267 *       STA     ,X+     ; #2~6
1268 *       BRA     CMOVLE  ; #2~3
1269 * CMOVLP
1270 *       LDD     ,Y++    ; #2~8
1271 *       STD     ,X++    ; #2~8
1272 * CMOVLI
1273 *       LDD     ,U      ; #2~5
1274 * CMOVLE
1275 *       SUBD    #2      ; #3~4
1276 *       STD     ,U      ; #2~5
1277 *       BPL     CMOVLP  ; #2~3
1278 *       LEAU    3*NATWID,U      ; #2~5
1279 *       PULS    Y,PC    ; #2~9
1280 * From the 6800 model:
1281 * CMOVE FDB     *+2     takes ( 43+47*count cycles ) on 6800
1282 *       LDX     #N
1283 *       LDB #6
1284 * CMOV1 PULS A  ;
1285 *       STA 0,X move parameters to scratch area
1286 *       LEAX 1,X        ;
1287 *       DECB    ;
1288 *       BNE     CMOV1
1289 * CMOV2 LDA N
1290 *       LDB N+1
1291 *       SUBB #1
1292 *       SBCA #0
1293 *       STA N
1294 *       STB N+1
1295 *       BCS     CMOV3
1296 *       LDX     N+4
1297 *       LDA 0,X
1298 *       LEAX 1,X        ;
1299 *       STX     N+4
1300 *       LDX     N+2
1301 *       STA 0,X
1302 *       LEAX 1,X        ;
1303 *       STX     N+2
1304 *       BRA     CMOV2
1305 * CMOV3 JMP     NEXT
1306 *
1307 * ######>> screen 23 <<
1308 * ======>>  18  <<
1309 * ( u1 u2 --- ud )
1310 * Multiplies the top two unsigned integers,
1311 * yielding a double integer product.
1312         FCB     $82
1313         FCC     'U'     ; 'U*'
1314         FCB     $AA
1315         FDB     CMOVE-8
1316 USTAR   FDB     *+NATWID
1317         LEAU    -2*NATWID,U
1318         LDA     2*NATWID+1,U    ; least
1319         LDB     3*NATWID+1,U
1320         MUL
1321         STD     NATWID,U
1322         LDA     2*NATWID,U      ; most
1323         LDB     3*NATWID,U
1324         MUL
1325         STD     ,U
1326         LDD     2*NATWID+1,U    ; first inner (u2 lo, u1 hi)
1327         MUL
1328         ADDD    1,U
1329         BCC     USTAR3
1330         INC     ,U
1331 USTAR3  STD     1,U
1332         LDA     2*NATWID,U      ; second inner (u2 hi)
1333         LDB     3*NATWID,U      ; (u1 lo)
1334         MUL
1335         ADDD    1,U
1336         BCC     USTAR4
1337         INC     ,U
1338 USTAR4  STD     1,U
1339         PULS    D,X
1340         STD     ,U
1341         STX     NATWID,U
1342         RTS
1343 *
1344 * from 6800 model:
1345 *       BSR     USTARS
1346 *       LEAS 1,S        ;
1347 *       LEAS 1,S        ;
1348 *       JMP     PUSHBA
1349 *
1350 * The following is a subroutine which
1351 * multiplies top 2 words on stack,
1352 * leaving 32-bit result:  high order word in A,B
1353 * low order word in 2nd word of stack.
1354 *
1355 * USTARS        LDA #16 bits/word counter
1356 *       PSHS A  ;
1357 *       CLRA    ;
1358 *       CLRB    ;
1359 *       TFR S,X ; TSX :
1360 * USTAR2        ROR 5,X shift multiplier
1361 *       ROR 6,X
1362 *       DEC 0,X done?
1363 *       BMI     USTAR4
1364 *       BCC     USTAR3
1365 *       ADDB 4,X
1366 *       ADCA 3,X
1367 * USTAR3        RORA    ;
1368 *       RORB    ;               shift result
1369 *       BRA     USTAR2
1370 * USTAR4        LEAS 1,S        ;               dump counter
1371 *       RTS
1372 *
1373 * ######>> screen 24 <<
1374 * ======>>  19  <<
1375 * ( ud u --- uremainder uquotient )
1376 * Divides the top unsigned integer
1377 * into the second and third words on the stack
1378 * as a single unsigned double integer,
1379 * leaving the remainder and quotient (quotient on top)
1380 * as unsigned integers.
1381 *
1382 *    The smaller the divisor, the more likely dropping the high word
1383 *    of the quotient loses significant bits. See M/MOD .
1384 *
1385         FCB     $82
1386         FCC     'U'     ; 'U/'
1387         FCB     $AF
1388         FDB     USTAR-5
1389 USLASH  FDB     *+NATWID
1390         LDA     #17     ; bit ct
1391         PSHS    A
1392         LDD     NATWID,U        ; dividend
1393 USLDIV  CMPD    ,U      ; divisor
1394         BHS     USLSUB
1395         ANDCC   #~1     ; carry clear
1396         BRA     USLBIT
1397 USLSUB  SUBD    ,U
1398         ORCC    #1      ; quotient, (carry set)
1399 USLBIT  ROL     2*NATWID+1,U    ; save it
1400         ROL     2*NATWID,U
1401         DEC     ,S      ; more bits?
1402         BEQ     USLR
1403         ROLB            ; remainder
1404         ROLA
1405         BCC     USLDIV
1406         BRA     USLSUB
1407 USLR    LEAU    NATWID,U
1408         LDX     NATWID,U
1409         STD     NATWID,U
1410         STX     ,U
1411         PULS    A,PC    ; Avoiding a LEAS 1,S by discarding A.
1412 *
1413 * from 6800 model:
1414 *       LDA #17
1415 *       PSHS A  ;
1416 *       TFR S,X ; TSX :
1417 *       LDA 3,X
1418 *       LDB 4,X
1419 * USL1  CMPA 1,X
1420 *       BHI     USL3
1421 *       BCS     USL2
1422 *       CMPB 2,X
1423 *       BCC     USL3
1424 * USL2  ANDCC #~$01     ; CLC :
1425 *       BRA     USL4
1426 * USL3  SUBB 2,X
1427 *       SBCA 1,X
1428 *       ORCC #$01       ; SEC :
1429 * USL4  ROL 6,X
1430 *       ROL 5,X
1431 *       DEC 0,X
1432 *       BEQ     USL5
1433 *       ROLB    ;
1434 *       ROLA    ;
1435 *       BCC     USL1
1436 *       BRA     USL3
1437 * USL5  LEAS 1,S        ;
1438 *       LEAS 1,S        ;
1439 *       LEAS 1,S        ;
1440 *       LEAS 1,S        ;
1441 *       LEAS 1,S        ;
1442 *       JMP     SWAP+4  reverse quotient & remainder
1443 *
1444 * ######>> screen 25 <<
1445 * ======>>  20  <<
1446 * ( n1 n2 --- n )
1447 * Bitwise and the top two integers.
1448         FCB     $83
1449         FCC     'AN'    ; 'AND'
1450         FCB     $C4
1451         FDB     USLASH-5
1452 AND     FDB     *+NATWID
1453         PULU    A,B
1454         ANDB    1,U
1455         ANDA    ,U
1456         STD     ,U
1457         RTS
1458 *       PULS A  ;
1459 *       PULS B  ;
1460 *       TFR S,X ; TSX :
1461 *       ANDB 1,X
1462 *       ANDA 0,X
1463 *       JMP     STABX
1464 *
1465 * ======>>  21  <<
1466 * ( n1 n2 --- n )
1467 * Bitwise or the top two integers.
1468         FCB     $82
1469         FCC     'O'     ; 'OR'
1470         FCB     $D2
1471         FDB     AND-6
1472 OR      FDB     *+NATWID
1473         PULU    A,B
1474         ORB     1,U
1475         ORA     ,U
1476         STD     ,U
1477         RTS
1478 *       PULS A  ;
1479 *       PULS B  ;
1480 *       TFR S,X ; TSX :
1481 *       ORB 1,X
1482 *       ORA 0,X
1483 *       JMP     STABX
1484 *
1485 * ======>>  22  <<
1486 * ( n1 n2 --- n )
1487 * Bitwise exclusive or the top two integers.
1488         FCB     $83
1489         FCC     'XO'    ; 'XOR'
1490         FCB     $D2
1491         FDB     OR-5
1492 XOR     FDB     *+NATWID
1493         PULU    A,B
1494         EORB    1,U
1495         EORA    ,U
1496         STD     ,U
1497         RTS
1498 *       PULS A  ;
1499 *       PULS B  ;
1500 *       TFR S,X ; TSX :
1501 *       EORB 1,X
1502 *       EORA 0,X
1503 *       JMP     STABX
1504 *
1505 * ######>> screen 26 <<
1506 * ======>>  23  <<
1507 * ( --- adr )
1508 * Fetch the parameter stack pointer (before it is pushed).
1509 * This points at whatever was on the top of stack before.
1510         FCB     $83
1511         FCC     'SP'    ; 'SP@'
1512         FCB     $C0
1513         FDB     XOR-6
1514 SPAT    FDB     *+NATWID
1515         TFR     U,X
1516         PSHU    X
1517         RTS
1518 *       TFR S,X ; TSX :
1519 *       STX     N       scratch area
1520 *       LDX     #N
1521 *       JMP     GETX
1522 *
1523 * ======>>  24  <<
1524 * ( whatever --- nothing )
1525 * Initialize the parameter stack pointer from the USER variable S0.
1526 * Effectively clears the stack.
1527         FCB     $83
1528         FCC     'SP'    ; 'SP!'
1529         FCB     $A1
1530         FDB     SPAT-6
1531 SPSTOR  FDB     *+NATWID
1532         LDU     <XSPZER
1533         RTS
1534 *       LDX     UP
1535 *       LDX     XSPZER-UORIG,X
1536 *       TFR X,S ; TXS :                 watch it ! X and S are not equal on 6800.
1537 *       JMP     NEXT
1538 * ======>>  25  <<
1539 * ( whatever *** nothing )
1540 * Initialize the return stack pointer from the initialization table
1541 * instead of the user variable R0, for some reason.
1542 * Quite possibly, this should be from R0.
1543 * Effectively aborts all in process definitions, except the active one.
1544 * An emergency measure, to be sure.
1545 * The routine that calls this must never execute a return.
1546 * So this should never be executed from the terminal, I guess.
1547 * This is another that should be compile-time only, and in a separate vocabulary.
1548         FCB     $83
1549         FCC     'RP'    ; 'RP!'
1550         FCB     $A1
1551         FDB     SPSTOR-6
1552 RPSTOR  FDB     *+NATWID
1553         PULS    X       ; But this guy has to return to his caller.
1554         LDS     RINIT
1555         JMP     ,X
1556 *       LDX     RINIT   initialize from rom constant
1557 *       STX     RP
1558 *       JMP     NEXT
1559 *
1560 * ======>>  26  <<
1561 * ( ip *** )
1562 * Pop IP from return stack (return from high-level definition).
1563 * Can be used in a screen to force interpretion to terminate.
1564 * Must not be executed when temporaries are saved on top of the return stack.
1565         FCB     $82
1566         FCC     ';'     ; ';S'
1567         FCB     $D3
1568         FDB     RPSTOR-6
1569 SEMIS   FDB     *+NATWID
1570         PULS    D,Y     ; return address in D, and saved IP in Y.
1571         TFR     D,PC    ; Synthetic return.
1572 *
1573 * Form 6800 model:
1574 *       LDX     RP
1575 *       LEAX 1,X        ;
1576 *       LEAX 1,X        ;
1577 *       STX     RP
1578 *       LDX     0,X     get address we have just finished.
1579 *       JMP     NEXT+2  increment the return address & do next word
1580 *
1581 * ######>> screen 27 <<
1582 * ======>>  27  <<
1583 * ( limit index *** index index )
1584 * Force the terminating condition for the innermost loop by
1585 * copying its index to its limit.
1586 * Termination is postponed until the next
1587 * LOOP or +LOOP instruction is executed.
1588 * The index remains available for use until
1589 * the LOOP or +LOOP instruction is encountered.
1590 * Note that the assumption is that the current count is the correct count
1591 * to end at, rather than pushing the count to the final count.
1592         FCB     $85
1593         FCC     'LEAV'  ; 'LEAVE'
1594         FCB     $C5
1595         FDB     SEMIS-5
1596 LEAVE   FDB     *+NATWID
1597         LDD     NATWID,S        ; Dodge the return address.
1598         STD     2*NATWID,S
1599         RTS
1600 *       LDX     RP
1601 *       LDA 2,X
1602 *       LDB 3,X
1603 *       STA 4,X
1604 *       STB 5,X
1605 *       JMP     NEXT
1606 *
1607 * ======>>  28  <<
1608 * ( n --- )
1609 * ( *** n )
1610 * Move top of parameter stack to top of return stack.
1611         FCB     $82
1612         FCC     '>'     ; '>R'
1613         FCB     $D2
1614         FDB     LEAVE-8
1615 TOR     FDB     *+NATWID
1616         PULU    A,B
1617         LDX     ,S
1618         STD     ,S      ; Put it where the return address was.
1619         JMP     ,X
1620 *       LDX     RP
1621 *       LEAX -1,X       ;
1622 *       LEAX -1,X       ;
1623 *       STX     RP
1624 *       PULS A  ;
1625 *       PULS B  ;
1626 *       STA 2,X
1627 *       STB 3,X
1628 *       JMP     NEXT
1629 *
1630 * ======>>  29  <<
1631 * ( --- n )
1632 * ( n *** )
1633 * Move top of return stack to top of parameter stack.
1634         FCB     $82
1635         FCC     'R'     ; 'R>'
1636         FCB     $BE
1637         FDB     TOR-5
1638 FROMR   FDB     *+NATWID
1639         PULS    D,X
1640         PSHU    X
1641         TFR     D,PC
1642 *       LDX     RP
1643 *       LDA 2,X
1644 *       LDB 3,X
1645 *       LEAX 1,X        ;
1646 *       LEAX 1,X        ;
1647 *       STX     RP
1648 *       JMP     PUSHBA
1649 *
1650 * ======>>  30  <<
1651 * ( --- n )
1652 * ( n *** n )
1653 * Copy the top of return stack to top of parameter stack.
1654 * A synonym for I.
1655         FCB     $81     R
1656         FCB     $D2
1657         FDB     FROMR-5
1658 R       FDB     I+NATWID
1659
1660 *       LDX     RP
1661 *       LEAX 1,X        ;
1662 *       LEAX 1,X        ;
1663 *       JMP     GETX
1664 *
1665 * ######>> screen 28 <<
1666 * ======>>  31  <<
1667 * ( n --- n=0 )
1668 * Logically invert top of stack;
1669 * or flag true if top is zero, otherwise false.
1670         FCB     $82
1671         FCC     '0'     ; '0='
1672         FCB     $BD
1673         FDB     R-4
1674 ZEQU    FDB     *+NATWID
1675         LDD     #0
1676         LDX     ,U
1677         BNE     ZEQUF
1678         INCB    ; 1 is true
1679 ZEQUF   STD     ,U
1680         RTS
1681 *       TFR S,X ; TSX :
1682 *       CLRA    ;
1683 *       CLRB    ;
1684 *       LDX     0,X
1685 *       BNE     ZEQU2
1686 *       INCB    ;
1687 *ZEQU2  TFR S,X ; TSX :
1688 *       JMP     STABX
1689 *
1690 * ======>>  32  <<
1691 * ( n --- n<0 )
1692 * Flag true if top is negative (MSbit set), otherwise false.
1693         FCB     $82
1694         FCC     '0'     ; '0<'
1695         FCB     $BC
1696         FDB     ZEQU-5
1697 ZLESS   FDB     *+NATWID
1698         LDD     #0
1699         TST     ,U
1700         BPL     ZLESSF
1701         INCB
1702 ZLESSF  STD     ,U
1703         RTS
1704 *       TFR S,X ; TSX :
1705 *       LDA #$80        check the sign bit
1706 *       ANDA 0,X
1707 *       BEQ     ZLESS2
1708 *       CLRA    ;               if neg.
1709 *       LDB #1
1710 *       JMP     STABX
1711 * ZLESS2        CLRB    ;
1712 *       JMP     STABX
1713 *
1714 * ######>> screen 29 <<
1715 * ======>>  33  <<
1716 * ( n1 n2 --- n1+n2 )
1717 * Add top two words.
1718         FCB     $81     '+'
1719         FCB     $AB
1720         FDB     ZLESS-5
1721 PLUS    FDB     *+NATWID
1722         PULU    A,B     ; #2~7
1723         ADDD    ,U      ; #2~6
1724         STD     ,U      ; #2~5
1725         RTS             ; #1~5  =#7~23
1726 *       PULS A  ;
1727 *       PULS B  ;
1728 *       TFR S,X ; TSX :
1729 *       ADDB 1,X
1730 *       ADCA 0,X
1731 *       JMP     STABX
1732 *
1733 * ======>>  34  <<
1734 * ( d1 d2 --- d1+d2 )
1735 * Add top two double integers.
1736         FCB     $82
1737         FCC     'D'     ; 'D+'
1738         FCB     $AB
1739         FDB     PLUS-4
1740 DPLUS   FDB     *+NATWID
1741         LDD     3*NATWID,U
1742         ADDD    NATWID,U
1743         STD     3*NATWID,U
1744         LDD     2*NATWID,U
1745         ADCB    1,U
1746         ADCA    ,U
1747         LEAU    2*NATWID,U
1748         STD     ,U
1749         RTS
1750 *       TFR S,X ; TSX :
1751 *       ANDCC #~$01     ; CLC :
1752 *       LDB #4
1753 * DPLUS2        LDA 3,X
1754 *       ADCA 7,X
1755 *       STA 7,X
1756 *       LEAX -1,X       ;
1757 *       DECB    ;
1758 *       BNE     DPLUS2
1759 *       LEAS 1,S        ;
1760 *       LEAS 1,S        ;
1761 *       LEAS 1,S        ;
1762 *       LEAS 1,S        ;
1763 *       JMP     NEXT
1764 *
1765 * ======>>  35  <<
1766 * ( n --- -n )
1767 * Negate (two's complement) top of stack.
1768         FCB     $85
1769         FCC     'MINU'  ; 'MINUS'
1770         FCB     $D3
1771         FDB     DPLUS-5
1772 MINUS   FDB     *+NATWID
1773         LDD     #0      ; #3~3
1774         SUBD    ,U      ; #2~5
1775         STD     ,U      ; #2~5
1776         RTS             ; #1~5  = #8~18
1777 *
1778 * from 6800 model code:
1779 *       TFR S,X ; TSX :
1780 *       NEG 1,X
1781 *       BCC     MINUS2
1782 *       NEG 0,X
1783 *       BRA     MINUS3
1784 * MINUS2        COM 0,X
1785 * MINUS3        JMP     NEXT
1786 *
1787 * ======>>  36  <<
1788 * ( d --- -d )
1789 * Negate (two's complement) top two words on stack as a double integer.
1790         FCB     $86
1791         FCC     'DMINU' ; 'DMINUS'
1792         FCB     $D3
1793         FDB     MINUS-8
1794 DMINUS  FDB     *+NATWID
1795         LDD     #0      ; #3~3
1796         SUBD    NATWID,U        ; #2~7
1797         STD     NATWID,U        ; #2~7
1798         LDD     #0      ; #3~3
1799         SBCB    1,U     ; #2~5
1800         SBCA    ,U      ; #2~4
1801         STD     ,U      ; #2~5
1802         RTS             ; #1~5  = #17~39
1803 *       TFR S,X ; TSX :
1804 *       COM 0,X
1805 *       COM 1,X
1806 *       COM 2,X
1807 *       NEG 3,X
1808 *       BNE     DMINX
1809 *       INC 2,X
1810 *       BNE     DMINX
1811 *       INC 1,X
1812 *       BNE     DMINX
1813 *       INC 0,X
1814 * DMINX JMP     NEXT
1815 *
1816 * ######>> screen 30 <<
1817 * ======>>  37  <<
1818 * ( n1 n2 --- n1 n2 n1 )
1819 * Push a copy of the second word on stack.
1820         FCB     $84
1821         FCC     'OVE'   ; 'OVER'
1822         FCB     $D2
1823         FDB     DMINUS-9
1824 OVER    FDB     *+NATWID
1825         LDD     NATWID,U
1826         PSHU    D
1827         RTS
1828 *       TFR S,X ; TSX :
1829 *       LDA 2,X
1830 *       LDB 3,X
1831 *       JMP     PUSHBA
1832 *
1833 * ======>>  38  <<
1834 * ( n --- )
1835 * Discard the top word on stack.
1836         FCB     $84
1837         FCC     'DRO'   ; 'DROP'
1838         FCB     $D0
1839         FDB     OVER-7
1840 DROP    FDB     *+NATWID
1841         LEAU    NATWID,U
1842         RTS
1843 *       LEAS 1,S        ;
1844 *       LEAS 1,S        ;
1845 *       JMP     NEXT
1846 *
1847 * ======>>  39  <<
1848 * ( n1 n2 --- n2 n1 )
1849 * Swap the top two words on stack.
1850         FCB     $84
1851         FCC     'SWA'   ; 'SWAP'
1852         FCB     $D0
1853         FDB     DROP-7
1854 SWAP    FDB     *+NATWID
1855         PULU    D,X
1856         PSHU    D
1857         PSHU    X
1858         RTS
1859 *       PULS A  ;
1860 *       PULS B  ;
1861 *       TFR S,X ; TSX :
1862 *       LDX     0,X
1863 *       LEAS 1,S        ;
1864 *       LEAS 1,S        ;
1865 *       PSHS B  ;
1866 *       PSHS A  ;
1867 *       STX     N
1868 *       LDX     #N
1869 *       JMP     GETX
1870 *
1871 * ======>>  40  <<
1872 * ( n1 --- n1 n1 )
1873 * Push a copy of the top word on stack.
1874         FCB     $83
1875         FCC     'DU'    ; 'DUP'
1876         FCB     $D0
1877         FDB     SWAP-7
1878 DUP     FDB     *+NATWID
1879         LDD     ,U
1880         PSHU    D
1881         RTS
1882 *       PULS A  ;
1883 *       PULS B  ;
1884 *       PSHS B  ;
1885 *       PSHS A  ;
1886 *       JMP PUSHBA
1887 *
1888 * ######>> screen 31 <<
1889 * ======>>  41  <<
1890 * ( n adr --- )
1891 * Add the second word on stack to the word at the adr on top of stack.
1892         FCB     $82
1893         FCC     '+'     ; '+!'
1894         FCB     $A1
1895         FDB     DUP-6
1896 PSTORE  FDB     *+NATWID
1897         PULU    X
1898         LDD     ,X
1899         ADDD    ,U++
1900         STD     ,X
1901         RTS
1902 *       TFR S,X ; TSX :
1903 *       LDX     0,X
1904 *       LEAS 1,S        ;
1905 *       LEAS 1,S        ;
1906 *       PULS A  ; get stack data
1907 *       PULS B  ;
1908 *       ADDB 1,X        add & store low byte
1909 *       STB 1,X
1910 *       ADCA 0,X        add & store hi byte
1911 *       STA 0,X
1912 *       JMP     NEXT
1913 *
1914 * ======>>  42  <<
1915 * ( adr b --- )
1916 * Exclusive or byte at adr with low byte of top word.
1917         FCB     $86
1918         FCC     'TOGGL' ; 'TOGGLE'
1919         FCB     $C5
1920         FDB     PSTORE-5
1921 TOGGLE  FDB     *+NATWID
1922         PULU    D,X
1923         EORB    ,X
1924         STB     ,X
1925         RTS
1926 * Using the model code would be less likely to introduce bugs,
1927 * but that would sort-of defeat my purposes here.
1928 * Anyway, I can borrow from theoretically known good bif-6809 code
1929 * and it's fewer bytes and much faster code this way.
1930 * TOGGLE
1931 *       FDB     DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1932 *       FDB     SEMIS
1933 *
1934 * ######>> screen 32 <<
1935 * ======>>  43  <<
1936 * ( adr --- n )
1937 * Replace address on stack with the word at the address.
1938         FCB     $81     @
1939         FCB     $C0
1940         FDB     TOGGLE-9
1941 AT      FDB     *+NATWID
1942         LDD     [,U]
1943         STD     ,U
1944         RTS
1945 *       TFR S,X ; TSX :
1946 *       LDX     0,X     get address
1947 *       LEAS 1,S        ;
1948 *       LEAS 1,S        ;
1949 *       JMP     GETX
1950 *
1951 * ======>>  44  <<
1952 * ( adr --- b )
1953 * Replace address on top of stack with the byte at the address.
1954 * High byte of result is clear.
1955         FCB     $82
1956         FCC     'C'     ; 'C@'
1957         FCB     $C0
1958         FDB     AT-4
1959 CAT     FDB     *+NATWID
1960         LDB     [,U]
1961         CLRA
1962         STD     ,U
1963         RTS
1964
1965
1966 *       TFR S,X ; TSX :
1967 *       LDX     0,X
1968 *       CLRA    ;
1969 *       LDB 0,X
1970 *       LEAS 1,S        ;
1971 *       LEAS 1,S        ;
1972 *       JMP     PUSHBA
1973 *
1974 * ======>>  45  <<
1975 * ( n adr --- )
1976 * Store second word on stack at address on top of stack.
1977         FCB     $81
1978         FCB     $A1
1979         FDB     CAT-5
1980 STORE   FDB     *+NATWID
1981         LDD     NATWID,U
1982         STD     [,U]
1983         LEAU    2*NATWID,U
1984         RTS
1985 *       TFR S,X ; TSX :
1986 *       LDX     0,X     get address
1987 *       LEAS 1,S        ;
1988 *       LEAS 1,S        ;
1989 *       JMP     PULABX
1990 *
1991 * ======>>  46  <<
1992 * ( b adr --- )
1993 * Store low byte of second word on stack at address on top of stack.
1994 * High byte is ignored.
1995         FCB     $82
1996         FCC     'C'     ; 'C!'
1997         FCB     $A1
1998         FDB     STORE-4
1999 CSTORE  FDB     *+NATWID
2000         LDB     3,U
2001         STB     [,U]
2002         LEAU    2*NATWID,U
2003         RTS
2004 *       TFR S,X ; TSX :
2005 *       LDX     0,X     get address
2006 *       LEAS 1,S        ;
2007 *       LEAS 1,S        ;
2008 *       LEAS 1,S        ;
2009 *       PULS B  ;
2010 *       STB 0,X
2011 *       JMP     NEXT
2012         PAGE
2013 *
2014 * ######>> screen 33 <<
2015 * ======>>  47  <<
2016 * ( --- )                                                 P
2017 * { : name sundry-activities ; } typical input
2018 * If executing (not compiling),
2019 * record the data stack mark in CSP,
2020 * Set the CONTEXT vocabulary to CURRENT,
2021 * CREATE a header,
2022 * set state to compile,
2023 * and compile the call to the trailing native CPU machine code DOCOL.
2024 *
2025 * This would not be hard to flatten to native code.
2026 * But that's not the purpose of a model.
2027         FCB     $C1     : immediate
2028         FCB     $BA
2029         FDB     CSTORE-5
2030 COLON   FDB     DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
2031         FDB     CREATE,RBRAK
2032         FDB     PSCODE
2033
2034 * Here is the IP pusher for allowing
2035 * nested words in the virtual machine:
2036 * ( ;S is the equivalent un-nester )
2037
2038 * ( *** oldIP )
2039 * Characteristic of a colon (:) definition.
2040 * Begins execution of a high-level definition,
2041 * i. e., nests the definition and begins processing icodes.
2042 * Mechanically, it pushes the IP (Y register)
2043 * and loads the Parameter Field Address of the definition which
2044 * called it into the IP.
2045 DOCOL   LDD     ,S      ; Save the return address.
2046         STY     ,S      ; Nest the old IP.
2047         LEAY    NATWID,X        ; W still in X, bump to parameters, load as new IP.
2048         TFR     D,PC    ; synthetic return to interpret.
2049
2050 * DOCOL LDX     RP      make room in the stack
2051 *       LEAX -1,X       ;
2052 *       LEAX -1,X       ;
2053 *       STX     RP
2054 *       LDA IP
2055 *       LDB IP+1
2056 *       STA 2,X Store address of the high level word
2057 *       STB 3,X that we are starting to execute
2058 *       LDX     W       Get first sub-word of that definition
2059 *       JMP     NEXT+2  and execute it
2060 *
2061 * ======>>  48  <<
2062 * ( --- )                                                 P
2063 * { : name sundry-activities ; } typical input
2064 * ERROR check data stack against mark in CSP,
2065 * compile ;S,
2066 * unSMUDGE LATEST definition,
2067 * and set state to interpretation.
2068         FCB     $C1     ;   imnediate code
2069         FCB     $BB
2070         FDB     COLON-4
2071 SEMI    FDB     DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
2072         FDB     SEMIS
2073 *
2074 * ######>> screen 34 <<
2075 * ======>>  49  <<
2076 * ( n --- )
2077 * { value CONSTANT name } typical input
2078 * CREATE a header,
2079 * unSMUDGE it,
2080 * compile the constant value,
2081 * and compile the call to the trailing native CPU machine code DOCON.
2082         FCB     $88
2083         FCC     'CONSTAN'       ; 'CONSTANT'
2084         FCB     $D4
2085         FDB     SEMI-4
2086 CON     FDB     DOCOL,CREATE,SMUDGE,COMMA,PSCODE
2087 * ( --- n )
2088 * Characteristic of a CONSTANT.
2089 * A CONSTANT simply loads its value from its parameter field
2090 * and pushes it on the stack.
2091 DOCON   LDD     NATWID,X        ; Get the first natural width word of the parameter field.
2092         PSHU    D
2093         RTS
2094 * DOCON LDX     W
2095 *       LDA 2,X
2096 *       LDB 3,X A & B now contain the constant
2097 *       JMP     PUSHBA
2098 *
2099 * Not in model, needed for abstraction:
2100 * ( --- NATWID )
2101 * The byte width of objects on stack.
2102         FCB     $86
2103         FCC     'NATWI' ; 'NATWID'
2104         FCB     $C4
2105         FDB     CON-11
2106 NATWC   FDB     DOCON
2107 NATWCV  FDB     NATWID
2108 *
2109 * Not in model, needed for abstraction:
2110 * Note that this is not defined as an INCREMENTER!
2111 * Coded to increment by the exact constant returned by NATWID
2112 * ( n --- n+NATWID )
2113         FCB     $84
2114         FCC     'NAT'   ; 'NAT+'
2115         FCB     $AB
2116         FDB     NATWC-9
2117 NATP    FDB     *+NATWID
2118         LDD     ,U
2119         ADDD    NATWCV,PCR      ; Looking ahead, does not have to be PCRelative.
2120         STD     ,U
2121         RTS
2122 * How this might have been done for 6800 model:
2123 *       CLRA    ; We know the natural width is less than 255, LOL.
2124 *       LDAB    NATWCV+1
2125 *       TSX
2126 *       ADDB    1,X
2127 *       ADCA    ,X
2128 *       JMP     STABX
2129 *
2130 * ======>>  50  <<
2131 * ( init --- )
2132 * { init VARIABLE name } typical input
2133 * Use CONSTANT to CREATE a header and compile the initial value, init,
2134 * then overwrite the characteristic to point to DOVAR.
2135         FCB     $88
2136         FCC     'VARIABL'       ; 'VARIABLE'
2137         FCB     $C5
2138         FDB     NATP-7
2139 VAR     FDB     DOCOL,CON,PSCODE
2140 * ( --- vadr )
2141 * Characteristic of a VARIABLE.
2142 * A VARIABLE pushes its PFA address on the stack.
2143 * The parameter field of a VARIABLE is the actual allocation of the variable,
2144 * so that pushing its address allows its contents to be @ed (fetched).
2145 * Ordinary arrays and strings that do not subscript themselves
2146 * may be allocated by defining a variable
2147 * and immediately ALLOTting the remaining needed space.
2148 * VARIABLES are global to all users,
2149 * and thus should be hidden in resource monitors, but aren't.
2150 DOVAR   LEAX    NATWID,X        ; Point to the first natural width word of the parameters.
2151         PSHU    X
2152         RTS
2153 * DOVAR LDA W
2154 *       LDB W+1
2155 *       ADDB #2
2156 *       ADCA #0 A,B now contain the address of the variable
2157 *       JMP     PUSHBA
2158 *
2159 * ======>>  51  <<
2160 * ( ub --- )
2161 * { uboffset USER name } typical input
2162 * CREATE a header and compile the unsigned byte offset in the per-USER table,
2163 * then overwrite the header with a call to DOUSER.
2164 * The USER is entirely responsible for maintaining allocation!
2165         FCB     $84
2166         FCC     'USE'   ; 'USER'
2167         FCB     $D2
2168         FDB     VAR-11
2169 USER    FDB     DOCOL,CON,PSCODE
2170 * ( --- vadr )
2171 * Characteristic of a per-USER variable.
2172 * USER variables are similiar to VARIABLEs,
2173 * but are allocated (by hand!) in the per-user table.
2174 * A USER variable's parameter field contains its offset in the per-user table.
2175 DOUSER  TFR     DP,A    ; Make a pointer to the direct page.
2176         CLRB
2177 *       See Alternative -- alternatives start from this point.
2178         ADDD    NATWID,X        ; Add it to the offset to the per-user variable.
2179         PSHU    D
2180         TFR     D,X     ; Cache the pointer in X for the caller.
2181         RTS
2182 * Hey, the per-user table could actually be larger than 256 bytes!
2183 * But we knew that. It's just not as esthetic to calculate it this way.
2184 * Alternative A:
2185 *       LDX     NATWID,X        ; Keep the offset
2186 *       EXG     D,X     ; Prepare for EA
2187 *       LEAX    D,X
2188 *       PSHU    X
2189 *       RTS
2190 * Alternative B:
2191 *       PSHS    Y       ; Get Y free for calculations.
2192 *       TFR     D,Y     ; Y points to the UP base
2193 *       LDD     NATWID,X        ; Get the offset
2194 *       LEAX    D,Y     ; Leave the pointer cached in X.
2195 *       PSHU    X
2196 *       PULS    Y,PC
2197 *
2198 * From the 6800 model:
2199 * DOUSER        LDX     W       get offset  into user's table
2200 *       LDA 2,X
2201 *       LDB 3,X
2202 *       ADDB UP+1       add to users base address
2203 *       ADCA UP
2204 *       JMP     PUSHBA  push address of user's variable
2205 *
2206 * ######>> screen 35 <<
2207 * ======>>  52  <<
2208 * ( --- 0 )
2209         FCB     $81
2210         FCB     $B0     0
2211         FDB     USER-7
2212 ZERO    FDB     DOCON
2213         FDB     0000
2214 *
2215 * ======>>  53  <<
2216 * ( --- 1 )
2217         FCB     $81
2218         FCB     $B1     1
2219         FDB     ZERO-4
2220 ONE     FDB     DOCON
2221 ONEV    FDB     1
2222 *
2223 * ======>>  54  <<
2224 * ( --- 2 )
2225         FCB     $81
2226         FCB     $B2     2
2227         FDB     ONE-4
2228 TWO     FDB     DOCON
2229 TWOV    FDB     2
2230 *
2231 * ======>>  55  <<
2232 * ( --- 3 )
2233         FCB     $81
2234         FCB     $B3     3
2235         FDB     TWO-4
2236 THREE   FDB     DOCON
2237         FDB     3
2238 *
2239 * ======>>  56  <<
2240 * ( --- SP )
2241 * ASCII SPACE character
2242         FCB     $82
2243         FCC     'B'     ; 'BL'
2244         FCB     $CC
2245         FDB     THREE-4
2246 BL      FDB     DOCON   ascii blank
2247         FDB     $20
2248 *
2249 * ======>>  57  <<
2250 * This really shouldn't be a CONSTANT.
2251 * ( --- adr )
2252 * The base of the disk buffer space.
2253         FCB     $85
2254         FCC     'FIRS'  ; 'FIRST'
2255         FCB     $D4
2256         FDB     BL-5
2257 FIRST   FDB     DOCON
2258         FDB     BUFBAS
2259 *       FDB     MEMEND-528      (132 * NBLK)
2260 *
2261 * ======>>  58  <<
2262 * This really shouldn't be a CONSTANT.
2263 * ( --- adr )
2264 * The limit of the disk buffer space.
2265         FCB     $85
2266         FCC     'LIMI'  ; 'LIMIT' :     ( the end of memory +1 )
2267         FCB     $D4
2268         FDB     FIRST-8
2269 LIMIT   FDB     DOCON
2270         FDB     BUFBAS+BUFSZ
2271 * In 6800 model, was
2272 *       FDB     MEMEND
2273 *
2274 * ======>>  59  <<
2275 * ( --- sectorsize )
2276 * The size, in bytes, of a buffer.
2277         FCB     $85
2278         FCC     'B/BU'  ; 'B/BUF' :     (bytes/buffer)
2279         FCB     $C6
2280         FDB     LIMIT-8
2281 BBUF    FDB     DOCON
2282         FDB     SECTSZ
2283 * Hardcoded in 6800 model:
2284 *       FDB     128
2285 *
2286 * ======>>  60  <<
2287 * ( --- blocksperscreen )
2288 * The size, in blocks, of a screen.
2289 * Should this be the same as NBLK, the number of block buffers maintained?
2290         FCB     $85
2291         FCC     'B/SC'  ; 'B/SCR' :     (blocks/screen)
2292         FCB     $D2
2293         FDB     BBUF-8
2294 BSCR    FDB     DOCON
2295         FDB     SCRSZ/SECTSZ
2296 * Hardcoded in 6800 model as:
2297 *       FDB     8
2298 *       blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
2299 *
2300 * ======>>  61  <<
2301 * ( n --- adr )
2302 * Calculate the address of entry (#n/2) in the boot-up parameter table.
2303 * (Adds the base of the boot-up table to n.)
2304         FCB     $87
2305         FCC     '+ORIGI'        ; '+ORIGIN'
2306         FCB     $CE
2307         FDB     BSCR-8
2308 PORIG   FDB     DOCOL,LIT,ORIG,PLUS
2309         FDB     SEMIS
2310 *
2311 * ######>> screen 36 <<
2312 * ======>>  62  <<
2313 * ( n --- adr )
2314 * This is the per-task variable recording the initial parameter stack pointer.
2315         FCB     $82
2316         FCC     'S'     ; 'S0'
2317         FCB     $B0
2318         FDB     PORIG-10
2319 SZERO   FDB     DOUSER
2320         FDB     XSPZER-UORIG
2321 *
2322 * ======>>  63  <<
2323 * ( n --- adr )
2324 * This is the per-task variable recording the initial return stack pointer.
2325         FCB     $82
2326         FCC     'R'     ; 'R0'
2327         FCB     $B0
2328         FDB     SZERO-5
2329 RZERO   FDB     DOUSER
2330         FDB     XRZERO-UORIG
2331 *
2332 * ======>>  64  <<
2333 * ( --- vadr )
2334 * Terminal Input Buffer address.
2335 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
2336         FCB     $83
2337         FCC     'TI'    ; 'TIB'
2338         FCB     $C2
2339         FDB     RZERO-5
2340 TIB     FDB     DOUSER
2341         FDB     XTIB-UORIG
2342 *
2343 * ======>>  65  <<
2344 * ( --- maxnamewidth )
2345 * This is the maximum width to which symbol names will be recorded.
2346         FCB     $85
2347         FCC     'WIDT'  ; 'WIDTH'
2348         FCB     $C8
2349         FDB     TIB-6
2350 WIDTH   FDB     DOUSER
2351         FDB     XWIDTH-UORIG
2352 *
2353 * ======>>  66  <<
2354 * ( --- vadr )
2355 * Availability of error messages on disk.
2356 * Contains 1 if messages available,
2357 * 0 if not,
2358 * -1 if a disk error has occurred.
2359         FCB     $87
2360         FCC     'WARNIN'        ; 'WARNING'
2361         FCB     $C7
2362         FDB     WIDTH-8
2363 WARN    FDB     DOUSER
2364         FDB     XWARN-UORIG
2365 *
2366 * ======>>  67  <<
2367 * ( --- vadr )
2368 * Boundary for FORGET.
2369         FCB     $85
2370         FCC     'FENC'  ; 'FENCE'
2371         FCB     $C5
2372         FDB     WARN-10
2373 FENCE   FDB     DOUSER
2374         FDB     XFENCE-UORIG
2375 *
2376 * ======>>  68  <<
2377 * ( --- vadr )
2378 * Dictionary pointer, fetched by HERE.
2379         FCB     $82
2380         FCC     'D'     ; 'DP' :        points to first free byte at end of dictionary
2381         FCB     $D0
2382         FDB     FENCE-8
2383 DICTPT  FDB     DOUSER
2384         FDB     XDICTP-UORIG
2385 *
2386 * ======>>  68.5  <<
2387 * ( --- vadr ) ******* Need to check what this is!
2388 * Used in maintaining vocabularies.
2389 * I think it points to the "parent" vocabulary, but I'm not sure.
2390 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
2391         FCB     $88
2392         FCC     'VOC-LIN'       ; 'VOC-LINK'
2393         FCB     $CB
2394         FDB     DICTPT-5
2395 VOCLIN  FDB     DOUSER
2396         FDB     XVOCL-UORIG
2397 *
2398 * ======>>  69  <<
2399 * ( --- vadr )
2400 * Disk block being interpreted.
2401 * Zero refers to terminal.
2402 * ******** Should be made a 32 bit user variable! ********
2403 * But the base system needs to have full 32 bit support, div and mul, etc.
2404 * before we can do that.
2405         FCB     $83
2406         FCC     'BL'    ; 'BLK'
2407         FCB     $CB
2408         FDB     VOCLIN-11
2409 BLK     FDB     DOUSER
2410         FDB     XBLK-UORIG
2411 *
2412 * ======>>  70  <<
2413 * ( --- vadr )
2414 * Input buffer offset/cursor.
2415         FCB     $82
2416         FCC     'I'     ; 'IN' :        scan pointer for input line buffer
2417         FCB     $CE
2418         FDB     BLK-6
2419 IN      FDB     DOUSER
2420         FDB     XIN-UORIG
2421 *
2422 * ======>>  71  <<
2423 * ( --- vadr )
2424 * Output buffer offset/cursor.
2425         FCB     $83
2426         FCC     'OU'    ; 'OUT'
2427         FCB     $D4
2428         FDB     IN-5
2429 OUT     FDB     DOUSER
2430         FDB     XOUT-UORIG
2431 *
2432 * ======>>  72  <<
2433 * ( --- vadr )
2434 * Screen currently being edited, once we have an editor running.
2435         FCB     $83
2436         FCC     'SC'    ; 'SCR'
2437         FCB     $D2
2438         FDB     OUT-6
2439 SCR     FDB     DOUSER
2440         FDB     XSCR-UORIG
2441 * ######>> screen 37 <<
2442 *
2443 * ======>>  73  <<
2444 * ( --- vadr )
2445 * Sector offset for LOADing screens,
2446 * set by DRIVE to make a new drive the default.
2447 * This should also be 32 bit or bigger.
2448         FCB     $86
2449         FCC     'OFFSE' ; 'OFFSET'
2450         FCB     $D4
2451         FDB     SCR-6
2452 OFSET   FDB     DOUSER
2453         FDB     XOFSET-UORIG
2454 *
2455 * ======>>  74  <<
2456 * ( --- vadr )
2457 * Current context of interpretation (vocabulary root).
2458         FCB     $87
2459         FCC     'CONTEX'        ; 'CONTEXT' :   points to pointer to vocab to search first
2460         FCB     $D4
2461         FDB     OFSET-9
2462 CONTXT  FDB     DOUSER
2463         FDB     XCONT-UORIG
2464 *
2465 * ======>>  75  <<
2466 * ( --- vadr )
2467 * Current context of definition (vocabulary root).
2468         FCB     $87
2469         FCC     'CURREN'        ; 'CURRENT' :   points to ptr. to vocab being extended
2470         FCB     $D4
2471         FDB     CONTXT-10
2472 CURENT  FDB     DOUSER
2473         FDB     XCURR-UORIG
2474 *
2475 * ======>>  76  <<
2476 * ( --- vadr )
2477 * Compiler/interpreter state.
2478         FCB     $85
2479         FCC     'STAT'  ; 'STATE' :     1 if compiling, 0 if not
2480         FCB     $C5
2481         FDB     CURENT-10
2482 STATE   FDB     DOUSER
2483         FDB     XSTATE-UORIG
2484 *
2485 * ======>>  77  <<
2486 * ( --- vadr )
2487 * Numeric conversion base.
2488         FCB     $84
2489         FCC     'BAS'   ; 'BASE' :      number base for all input & output
2490         FCB     $C5
2491         FDB     STATE-8
2492 BASE    FDB     DOUSER
2493         FDB     XBASE-UORIG
2494 *
2495 * ======>>  78  <<
2496 * ( --- vadr )
2497 * Decimal point location for output.
2498         FCB     $83
2499         FCC     'DP'    ; 'DPL'
2500         FCB     $CC
2501         FDB     BASE-7
2502 DPL     FDB     DOUSER
2503         FDB     XDPL-UORIG
2504 *
2505 * ======>>  79  <<
2506 * ( --- vadr )
2507 * Field width for I/O formatting.
2508         FCB     $83
2509         FCC     'FL'    ; 'FLD'
2510         FCB     $C4
2511         FDB     DPL-6
2512 FLD     FDB     DOUSER
2513         FDB     XFLD-UORIG
2514 *
2515 * ======>>  80  <<
2516 * ( --- vadr )
2517 * Compiler stack mark for stack check.
2518         FCB     $83
2519         FCC     'CS'    ; 'CSP'
2520         FCB     $D0
2521         FDB     FLD-6
2522 CSP     FDB     DOUSER
2523         FDB     XCSP-UORIG
2524 *
2525 * ======>>  81  <<
2526 * ( --- vadr )
2527 * Editing cursor location.
2528         FCB     $82
2529         FCC     'R'     ; 'R#'
2530         FCB     $A3
2531         FDB     CSP-6
2532 RNUM    FDB     DOUSER
2533         FDB     XRNUM-UORIG
2534 *
2535 * ======>>  82  <<
2536 * ( --- vadr )
2537 * Pointer to last HELD character in PAD.
2538         FCB     $83
2539         FCC     'HL'    ; 'HLD'
2540         FCB     $C4
2541         FDB     RNUM-5
2542 HLD     FDB     DOCON
2543         FDB     XHLD
2544 *
2545 * ======>>  82.5  <<== SPECIAL
2546 * ( --- vadr )
2547 * Line width of active terminal.
2548         FCB     $87
2549         FCC     'COLUMN'        ; 'COLUMNS' :   line width of terminal
2550         FCB     $D3
2551         FDB     HLD-6
2552 COLUMS  FDB     DOUSER
2553         FDB     XCOLUM-UORIG
2554 *
2555 * ######>> screen 38 <<
2556 **
2557 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
2558 **
2559 ** Make an INCREMENTER compiling word (not in model):
2560 ** ( n --- )
2561 ** { n INCREMENTER name } typical input
2562 ** CREATE a header and compile the increment constant,
2563 ** then overwrite the header with a call to DOINC.
2564 *       FCB     $8B
2565 *       FCC     'INCREMENTE'    ; 'INCREMENTER'
2566 *       FCB     $D2
2567 *       FDB     COLUMS-10
2568 * INCR  FDB     DOCOL,CON,PSCODE
2569 ** ( n --- ninc )
2570 ** Characteristic of an INCREMENTER.
2571 ** This is too naive:
2572 * DOINC LDD     ,U
2573 *       ADDD    NATWID,X        ; Add the increment.
2574 *       STD     ,U
2575 *       RTS
2576 * Compiling word should check that it is compiling a CONSTANT.
2577 *
2578 * ======>>  83  <<
2579 * ( n --- n+1 )
2580         FCB     $82
2581         FCC     '1'     ; '1+'
2582         FCB     $AB
2583         FDB     COLUMS-10
2584 * Using the model keeps things semantically connected for other processors:
2585 ONEP    FDB     DOCOL,ONE,PLUS
2586         FDB     SEMIS
2587 ** Greedy alternative:
2588 * ONEP  FDB     *+NATWID
2589 *       LDD     ,U
2590 *       ADDD    ONEV,PCR
2591 *       STD     ,U
2592 *       RTS
2593 * Naive alternative:
2594 * ONEP  FDB     DOINC
2595 *       FDB     1
2596 * Naive alternative:
2597 * ONEP  FDB     *+NATWID
2598 *       LDD     ,U
2599 *       ADDD    #1       ; It's hard to imagine 1+ being other than 1.
2600 *       STD     ,U
2601 *       RTS
2602 *
2603 * ======>>  84  <<
2604 * ( n --- n+2 )
2605         FCB     $82
2606         FCC     '2'     ; '2+'
2607         FCB     $AB
2608         FDB     ONEP-5
2609 * Using the model keeps things semantically connected for other processors:
2610 TWOP    FDB     DOCOL,TWO,PLUS
2611         FDB     SEMIS
2612 ** Greedy alternative:
2613 * TWOP  FDB     *+NATWID
2614 *       LDD     ,U
2615 *       ADDD    TWOV,PCR         ; See NAT+ (NATP)
2616 *       STD     ,U
2617 *       RTS
2618 * Naive alternative:
2619 * TWOP  FDB     DOINC
2620 *       FDB     2
2621 * Naive alternative:
2622 * TWOP  FDB     *+NATWID
2623 *       LDD     ,U
2624 *       ADDD    #2       ; See NAT+ (NATP)
2625 *       STD     ,U
2626 *       RTS
2627 *
2628 * ======>>  85  <<
2629 * ( --- adr )
2630 * Get the DICTPT allocation, like a USER constant.
2631 * Should check the stack and heap for collision.
2632         FCB     $84
2633         FCC     'HER'   ; 'HERE'
2634         FCB     $C5
2635         FDB     TWOP-5
2636 HERE    FDB     DOCOL,DICTPT,AT
2637         FDB     SEMIS
2638 *
2639 * ======>>  86  <<
2640 * ( n --- )
2641 * Increase/decrease heap (add n to DP),
2642 * Should ERROR check stack/heap.
2643         FCB     $85
2644         FCC     'ALLO'  ; 'ALLOT'
2645         FCB     $D4
2646         FDB     HERE-7
2647 ALLOT   FDB     DOCOL,DICTPT,PSTORE
2648         FDB     SEMIS
2649 *
2650 * ======>>  87  <<
2651 * ( n --- )
2652 * Store word n at DP++,
2653 * Should ERROR check stack/heap.
2654         FCB     $81     ; , (COMMA)
2655         FCB     $AC
2656         FDB     ALLOT-8
2657 COMMA   FDB     DOCOL,HERE,STORE,NATWC,ALLOT
2658         FDB     SEMIS
2659 * COMMA FDB     DOCOL,HERE,STORE,TWO,ALLOT
2660 *       FDB     SEMIS
2661 *
2662 * ======>>  88  <<
2663 * ( b --- )
2664 * Store byte b at DP+,
2665 * Should ERROR check stack/heap.
2666         FCB     $82
2667         FCC     'C'     ; 'C,'
2668         FCB     $AC
2669         FDB     COMMA-4
2670 CCOMM   FDB     DOCOL,HERE,CSTORE,ONE,ALLOT
2671         FDB     SEMIS
2672 *
2673 * ======>>  89  <<
2674 * ( n1 n2 --- n1-n2 )
2675 * Subtract top two words.
2676         FCB     $81     ; -
2677         FCB     $AD
2678         FDB     CCOMM-5
2679 SUB     FDB     *+NATWID
2680         LDD     NATWID,U        ; #2~6
2681         SUBD    ,U++    ; #2~9
2682         STD     ,U      ; #2~5
2683         RTS             ; #1~5  = #7~25
2684 * SUB   FDB     DOCOL,MINUS,PLUS
2685 *       FDB     SEMIS   ; Costs 6 bytes and lots of cycles.
2686 *
2687 * ======>>  90  <<
2688 * ( n1 n2 --- n1==n2 )
2689 * Return flag true if n1 and n2 are equal, otherwise false.
2690         FCB     $81     =
2691         FCB     $BD
2692         FDB     SUB-4
2693 EQUAL   FDB     DOCOL,SUB,ZEQU
2694         FDB     SEMIS
2695 *
2696 * ======>>  91  <<
2697 * ( n1 n2 --- n1<n2 )
2698 * Return flag true if n1 is less than n2, otherwise false.
2699         FCB     $81     <
2700         FCB     $BC
2701         FDB     EQUAL-4
2702 LESS    FDB     *+NATWID
2703         LDD     NATWID,U
2704         SUBD    ,U++
2705         BGE     FALSE
2706 TRUE    LDD     #1
2707         STD     ,U
2708         RTS
2709 FALSE   LDD     #0
2710         STD     ,U
2711         RTS
2712 *       PULS A  ;
2713 *       PULS B  ;
2714 *       TFR S,X ; TSX :
2715 *       CMPA 0,X
2716 *       LEAS 1,S        ;
2717 *       BGT     LESST
2718 *       BNE     LESSF
2719 *       CMPB 1,X        ; Why not sub, sbc, bge?
2720 *       BHI     LESST
2721 * LESSF CLRB    ;
2722 *       BRA     LESSX
2723 * LESST LDB #1
2724 * LESSX CLRA    ;
2725 *       LEAS 1,S        ;
2726 *       JMP     PUSHBA
2727 *
2728 * ======>>  92  <<
2729 * ( n1 n2 --- n1>n2 )
2730 * Return flag true if n1 is greater than n2, false otherwise.
2731         FCB     $81     >
2732         FCB     $BE
2733         FDB     LESS-4
2734 GREAT   FDB     DOCOL,SWAP,LESS
2735         FDB     SEMIS
2736 *
2737 * ======>>  93  <<
2738 * ( n1 n2 n3 --- n2 n3 n1 )
2739 * Rotate the top three words on stack,
2740 * bringing the third word to the top.
2741         FCB     $83
2742         FCC     'RO'    ; 'ROT'
2743         FCB     $D4
2744         FDB     GREAT-4
2745 ROT     FDB     *+NATWID
2746         PSHS    Y
2747         PULU    D,X,Y
2748         PSHU    D,X
2749         PSHU    Y
2750         PULS    Y,PC
2751 * ROT   FDB     DOCOL,TOR,SWAP,FROMR,SWAP
2752 *       FDB     SEMIS
2753 *
2754 * ======>>  94  <<
2755 * ( --- )
2756 * EMIT a SPACE.
2757         FCB     $85
2758         FCC     'SPAC'  ; 'SPACE'
2759         FCB     $C5
2760         FDB     ROT-6
2761 SPACE   FDB     DOCOL,BL,EMIT
2762         FDB     SEMIS
2763 *
2764 * ======>>  95  <<
2765 *  ( n0 n1 --- min(n0,n1) )
2766 * Leave the minimum of the top two integers.
2767 * Being too greedy here, but, whatever.
2768         FCB     $83
2769         FCC     'MI'    ; 'MIN'
2770         FCB     $CE
2771         FDB     SPACE-8
2772 MIN     FDB     *+NATWID
2773         PULU    D
2774         CMPD    ,U
2775         BLE     MINX
2776         STD     ,U
2777 MINX    RTS
2778 * MIN   FDB     DOCOL,OVER,OVER,GREAT,ZBRAN
2779 *       FDB     MIN2-*
2780 *       FDB     SWAP
2781 * MIN2  FDB     DROP
2782 *       FDB     SEMIS
2783 *
2784 * ======>>  96  <<
2785 * ( n0 n1 --- max(n0,n1) )
2786 * Leave the maximum of the top two integers.
2787 * Really should leave this as in the model.
2788         FCB     $83
2789         FCC     'MA'    ; 'MAX'
2790         FCB     $D8
2791         FDB     MIN-6
2792 MAX     FDB     *+NATWID
2793         PULU    D
2794         CMPD    ,U
2795         BLE     MAXX
2796         STD     ,U
2797 MAXX    RTS
2798 * MAX   FDB     DOCOL,OVER,OVER,LESS,ZBRAN
2799 *       FDB     MAX2-*
2800 *       FDB     SWAP
2801 * MAX2  FDB     DROP
2802 *       FDB     SEMIS
2803 *
2804 * ======>>  97  <<
2805 * ( 0 --- 0 )
2806 * ( n --- n n )
2807 * DUP if non-zero.
2808         FCB     $84
2809         FCC     '-DU'   ; '-DUP'
2810         FCB     $D0
2811         FDB     MAX-6
2812 DDUP    FDB     *+NATWID
2813         LDD     ,U
2814         BEQ     DDUPX
2815         PSHU    D
2816 DDUPX   RTS
2817 * DDUP  FDB     DOCOL,DUP,ZBRAN
2818 *       FDB     DDUP2-*
2819 *       FDB     DUP
2820 * DDUP2 FDB     SEMIS
2821 *
2822 * ######>> screen 39 <<
2823 * ======>> 98.1 <<
2824 * Supplemental:
2825 * ( n<0 --- -1 )
2826 * ( n>=~ --- 1 )
2827 * Change top integer to its sign.
2828         FCB     $86
2829         FCC     'SIGNU' ; 'SIGNUM'
2830         FCB     $CD
2831         FDB     DDUP-7
2832 SIGNUM  FDB     *+NATWID
2833 SIGNUE  LDB     #1
2834         LDA     ,U
2835         BPL     SIGNUP
2836         NEGB
2837 SIGNUP  SEX     ; Couldn't they have called SignEXtend EXT instead?
2838         STD     ,U      ; Am I too much of a prude?
2839         RTS
2840 * 6800 model version should be something like this:
2841 *       LDB     #1
2842 *       CLRA
2843 *       TSX
2844 *       TST     ,X
2845 *       BPL     SIGNUP
2846 *       NEGB
2847 *       COMA
2848 * SIGNUP        JMP     STABX
2849 *
2850 * ======>>  98  <<
2851 * ( adr1 direction --- adr2 )
2852 * TRAVERSE the symbol name.
2853 * If direction is 1, find the end.
2854 * If direction is -1, find the beginning.
2855         FCB     $88
2856         FCC     'TRAVERS'       ; 'TRAVERSE'
2857         FCB     $C5
2858         FDB     SIGNUM-9
2859 TRAV    FDB     *+NATWID
2860         BSR     SIGNUE  ; Convert negative to -, zero or positive to 1.
2861         LDD     ,U++    ; Still in D, but we have to pop it anyway.
2862         LDX     ,U      ; If D is 1 or -1, so is B.
2863         LDA     #$7F
2864 TRAVLP  LEAX    B,X     ; Don't look at the one we start at.
2865         CMPA    ,X      ; Not sure why we aren't just doing LDA ,X ; BPL.
2866         BCC     TRAVLP
2867 TRAVDN  STX     ,U
2868         RTS
2869 * Doing this in 6809 just because it can be done may be getting too greedy.
2870 * TRAV  FDB     DOCOL,SWAP
2871 * TRAV2 FDB     OVER,PLUS,LIT8
2872 *       FCB     $7F
2873 *       FDB     OVER,CAT,LESS,ZBRAN
2874 *       FDB     TRAV2-*
2875 *       FDB     SWAP,DROP
2876 *       FDB     SEMIS
2877 *
2878 * ======>>  99  <<
2879 * ( --- symptr )
2880 * Fetch CURRENT as a per-USER constant.
2881         FCB     $86
2882         FCC     'LATES' ; 'LATEST'
2883         FCB     $D4
2884         FDB     TRAV-11
2885 LATEST  FDB     DOCOL,CURENT,AT,AT
2886         FDB     SEMIS
2887 * LATEST        FDB     *+NATWID
2888 * Getting too greedy:
2889 * Version 1:
2890 *       TFR     DP,A
2891 *       CLRB
2892 *       TFR     D,X
2893 *       LDD     CURENT+NATWID,PCR
2894 *       LDX     [D,X]
2895 *       PSHU    X       ; Leave the address in X.
2896 *       RTS
2897 * Version 2:
2898 *       LEAX    CURENT,PCR
2899 *       JSR     [,X]
2900 *       PULU    X
2901 *       LDX     [,X]
2902 *       PSHU    X
2903 *       RTS
2904 * Too greedy, too many smantic holes to fall through.
2905 * If the address at the CFA is made relative,
2906 * this is part of the code that would be affected
2907 * if it is in native CPU code.
2908 *
2909 * ======>>  100  <<
2910 * Wanted to do these as INCREMENTERs,
2911 * but I need to stick with the model as much as possible,
2912 * (mostly, LOL) adding code only to make the model more clear.
2913 * ( pfa --- lfa )
2914 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
2915         FCB     $83
2916         FCC     'LF'    ; 'LFA'
2917         FCB     $C1
2918         FDB     LATEST-9
2919 LFA     FDB     DOCOL,LIT8
2920 *       FCB     4
2921         FCB     2*NATWID
2922         FDB     SUB
2923         FDB     SEMIS
2924 *
2925 * ======>>  101  <<
2926 * ( pfa --- cfa )
2927 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
2928         FCB     $83
2929         FCC     'CF'    ; 'CFA'
2930         FCB     $C1
2931         FDB     LFA-6
2932 * CFA   FDB     DOCOL,TWO,SUB
2933 CFA     FDB     DOCOL,NATWC,SUB
2934         FDB     SEMIS
2935 *
2936 * ======>>  102  <<
2937 * ( pfa --- nfa )
2938 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
2939         FCB     $83
2940         FCC     'NF'    ; 'NFA'
2941         FCB     $C1
2942         FDB     CFA-6
2943 NFA     FDB     DOCOL,LIT8
2944 *       FCB     5
2945         FCB     NATWID*2+1
2946         FDB     SUB,ONE,MINUS,TRAV
2947         FDB     SEMIS
2948 *
2949 * ======>>  103  <<
2950 * ( nfa --- pfa )
2951 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
2952         FCB     $83
2953         FCC     'PF'    ; 'PFA'
2954         FCB     $C1
2955         FDB     NFA-6
2956 PFA     FDB     DOCOL,ONE,TRAV,LIT8
2957 *       FCB     5
2958         FCB     NATWID*2+1
2959         FDB     PLUS
2960         FDB     SEMIS
2961 *
2962 * ######>> screen 40 <<
2963 * ======>>  104  <<
2964 * ( --- )
2965 * Save the parameter stack pointer in CSP for compiler checks.
2966         FCB     $84
2967         FCC     '!CS'   ; '!CSP'
2968         FCB     $D0
2969         FDB     PFA-6
2970 SCSP    FDB     DOCOL,SPAT,CSP,STORE
2971         FDB     SEMIS
2972 *
2973 * ======>>  105  <<
2974 * ( 0 n --- )             ( *** )
2975 * ( true n --- IN BLK )   ( anything *** nothing )
2976 * If flag is false, do nothing.
2977 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
2978 * Leaves cursor position (IN)
2979 * and currently loading block number (BLK) on stack, for analysis.
2980 *
2981 * This one is too important to be high-level Forth codes.
2982 * When we have an error, we want to disturb as little as possible.
2983 * But fixing that cascades through ERROR and MESSAGE
2984 * into the disk block system.
2985 * And we aren't ready for that yet.
2986         FCB     $86
2987         FCC     '?ERRO' ; '?ERROR'
2988         FCB     $D2
2989         FDB     SCSP-7
2990 * QERR  FDB     *+NATWID
2991 *       LDD     NATWID,U
2992 *       BNE     QERROR
2993 *       LEAU    2*NATWID,U
2994 *       RTS
2995 ** this doesn't work anyway: QERROR     LBR     ERROR
2996 QERR    FDB     DOCOL,SWAP,ZBRAN
2997         FDB     QERR2-*
2998         FDB     ERROR,BRAN
2999         FDB     QERR3-*
3000 QERR2   FDB     DROP
3001 QERR3   FDB     SEMIS
3002 *
3003 * ======>>  106  <<
3004 * STATE is compiling:
3005 * ( --- )                 ( *** )
3006 * STATE is compiling:
3007 * ( --- IN BLK )          ( anything *** nothing )
3008 * ERROR if not compiling.
3009         FCB     $85
3010         FCC     '?COM'  ; '?COMP'
3011         FCB     $D0
3012         FDB     QERR-9
3013 QCOMP   FDB     DOCOL,STATE,AT,ZEQU,LIT8
3014         FCB     $11
3015         FDB     QERR
3016         FDB     SEMIS
3017 *
3018 * ======>>  107  <<
3019 * STATE is executing:
3020 * ( --- )                 ( *** )
3021 * STATE is executing:
3022 * ( --- IN BLK )          ( anything *** nothing )
3023 * ERROR if not executing.
3024         FCB     $85
3025         FCC     '?EXE'  ; '?EXEC'
3026         FCB     $C3
3027         FDB     QCOMP-8
3028 QEXEC   FDB     DOCOL,STATE,AT,LIT8
3029         FCB     $12
3030         FDB     QERR
3031         FDB     SEMIS
3032 *
3033 * ======>>  108  <<
3034 * ( n1 n1 --- )           ( *** )
3035 * ( n1 n2 --- IN BLK )    ( anything *** nothing )
3036 * ERROR if top two are unequal.
3037 * MESSAGE says compiled conditionals do not match.
3038         FCB     $86
3039         FCC     '?PAIR' ; '?PAIRS'
3040         FCB     $D3
3041         FDB     QEXEC-8
3042 QPAIRS  FDB     DOCOL,SUB,LIT8
3043         FCB     $13
3044         FDB     QERR
3045         FDB     SEMIS
3046 *
3047 * ======>>  109  <<
3048 * CSP and parameter stack are balanced (equal):
3049 * ( --- )                 ( *** )
3050 * CSP and parameter stack are not balanced (unequal):
3051 * ( --- IN BLK )          ( anything *** nothing )
3052 * ERROR if return/control stack is not at same level as last !CSP.
3053 * Usually indicates that a definition has been left incomplete.
3054         FCB     $84
3055         FCC     '?CS'   ; '?CSP'
3056         FCB     $D0
3057         FDB     QPAIRS-9
3058 QCSP    FDB     DOCOL,SPAT,CSP,AT,SUB,LIT8
3059         FCB     $14
3060         FDB     QERR
3061         FDB     SEMIS
3062 *
3063 * ======>>  110  <<
3064 * Active BLK input:
3065 * ( --- )         ( *** )
3066 * No active BLK input:
3067 * ( --- IN BLK )          ( anything *** nothing )
3068 * ERROR if not loading, i. e., if BLK is zero.
3069         FCB     $88
3070         FCC     '?LOADIN'       ; '?LOADING'
3071         FCB     $C7
3072         FDB     QCSP-7
3073 QLOAD   FDB     DOCOL,BLK,AT,ZEQU,LIT8
3074         FCB     $16
3075         FDB     QERR
3076         FDB     SEMIS
3077 *
3078 * ######>> screen 41 <<
3079 * ======>>  111  <<
3080 * ( --- )
3081 * Compile an in-line literal value from the instruction stream.
3082         FCB     $87
3083         FCC     'COMPIL'        ; 'COMPILE'
3084         FCB     $C5
3085         FDB     QLOAD-11
3086 * COMPIL        FDB     DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
3087 COMPIL  FDB     DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3088         FDB     SEMIS
3089 *
3090 * ======>>  112  <<
3091 * ( --- )                                                 P
3092 * Clear the compile state bit(s) (shift to interpret).
3093         FCB     $C1     [       immediate
3094         FCB     $DB
3095         FDB     COMPIL-10
3096 LBRAK   FDB     DOCOL,ZERO,STATE,STORE
3097         FDB     SEMIS
3098 *
3099 * ======>>  113  <<
3100 *
3101 STCOMP  EQU     $C0
3102 * ( --- )
3103 * Set the compile state bit(s) (shift to compile).
3104         FCB     $81     ]
3105         FCB     $DD
3106         FDB     LBRAK-4
3107 RBRAK   FDB     DOCOL,LIT8
3108         FCB     STCOMP
3109         FDB     STATE,STORE
3110         FDB     SEMIS
3111 *
3112 * ======>>  114  <<
3113 * ( --- )
3114 * Toggle SMUDGE bit of LATEST definition header,
3115 * to hide it until defined or reveal it after definition.
3116         FCB     $86
3117         FCC     'SMUDG' ; 'SMUDGE'
3118         FCB     $C5
3119         FDB     RBRAK-4
3120 SMUDGE  FDB     DOCOL,LATEST,LIT8
3121         FCB     FSMUDG
3122         FDB     TOGGLE
3123         FDB     SEMIS
3124 *
3125 * ======>>  115  <<
3126 * ( --- )
3127 * Set the conversion base to sixteen (b00010000).
3128         FCB     $83
3129         FCC     'HE'    ; 'HEX'
3130         FCB     $D8
3131         FDB     SMUDGE-9
3132 HEX     FDB     DOCOL
3133         FDB     LIT8
3134         FCB     16      ; decimal sixteen
3135         FDB     BASE,STORE
3136         FDB     SEMIS
3137 *
3138 * ======>>  116  <<
3139 * ( --- )
3140 * Set the conversion base to ten (b00001010).
3141         FCB     $87
3142         FCC     'DECIMA'        ; 'DECIMAL'
3143         FCB     $CC
3144         FDB     HEX-6
3145 DEC     FDB     DOCOL
3146         FDB     LIT8
3147         FCB     10      ; decimal ten
3148         FDB     BASE,STORE
3149         FDB     SEMIS
3150 *
3151 * ######>> screen 42 <<
3152 * ======>>  117  <<
3153 * ( --- )         ( IP *** )
3154 * Pop the saved IP and use it to
3155 * compile the latest symbol as a reference to a ;CODE definition;
3156 * overwrite the code field of the symbol found by LATEST
3157 * with the address of the low-level characteristic code
3158 * provided in the defining definition.
3159 * Look closely at where things return, consider the operation of R> and >R .
3160 *
3161 * The machine-level code which follows (;CODE) in the instruction stream
3162 * is not executed by the defining symbol,
3163 * but becomes the characteristic of the defined symbol.
3164 * This is the usual way to generate the characteristics of VARIABLEs,
3165 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
3166 *
3167 * Finally, note that, if code shifts from low level back to high
3168 * (native CPU machine code calling into a list of FORTH codes),
3169 * the low level code can't just call a high-level definition.
3170 * Leaf definitions can directly call other leaf definitions,
3171 * but not non-leafs.
3172 * It will need an anonymous list, probably embedded in the low-level code,
3173 * and Y and X will have to be set appropriately before entering the list.
3174         FCB     $87
3175         FCC     '(;CODE'        ; '(;CODE)'
3176         FCB     $A9
3177         FDB     DEC-10
3178 * PSCODE        FDB     DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
3179 PSCODE  FDB     DOCOL,FROMR     ; Y/IP is post-inc, needs no adjustment.
3180         FDB     LATEST,PFA,CFA,STORE
3181         FDB     SEMIS
3182 *
3183 * ======>>  118  <<
3184 * ( --- )                                                 P
3185 * ?CSP to see if there are loose ends in the defining definition
3186 * before shifting to the assembler,
3187 * compile (;CODE) in the defining definition's instruction stream,
3188 * shift to interpreting,
3189 * make the ASSEMBLER vocabulary current,
3190 * and !CSP to mark the stack
3191 * in preparation for assembling low-level code.
3192 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
3193 * and compiles (;CODE),
3194 * which will do the actual work of changing
3195 * the LATEST definition's characteristic when the defining word runs.
3196 * Assembly is done by the interpreter, rather than the compiler.
3197 * I could have avoided the anomalous three-byte code fields by
3198 *
3199 * Note that the ASSEMBLER is not part of the model (at this time).
3200 * That means that, until the assembler is ready,
3201 * if you want to define low-level words,
3202 * you have to poke (comma) in hand-assembled stuff.
3203 *
3204         FCB     $C5     immediate
3205         FCC     ';COD'  ; ';CODE'
3206         FCB     $C5
3207         FDB     PSCODE-10
3208 SEMIC   FDB     DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
3209         FDB     SEMIS
3210 * note: "QSTACK" will be replaced by "ASSEMBLER" later
3211 *
3212 * ######>> screen 43 <<
3213 * ======>>  119  <<
3214 * ( --- )                                                 C
3215 * Make the word currently being defined
3216 * build a header for DOES> definitions.
3217 * Actually just compiles a CONSTANT zero
3218 * which can be overwritten later by DOES>.
3219 * Since the fig models were established, this technique has been deprecated.
3220 *
3221 * Note that <BUILDS is not IMMEDIATE,
3222 * and therefore executes during a definition's run-time,
3223 * rather than its compile-time.
3224 * It is not intended to be used directly,
3225 * but rather so that one definition word can build another.
3226 * Also, note that nothing particularly special happens
3227 * in the defining definition until DOES> executes.
3228 * The name <BUILDS is intended to be a reminder of what is about to occur.
3229 *
3230 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
3231         FCB     $87
3232         FCC     '<BUILD'        ; '<BUILDS'
3233         FCB     $D3
3234         FDB     SEMIC-8
3235 BUILDS  FDB     DOCOL,ZERO,CON
3236         FDB     SEMIS
3237 *
3238 * ======>>  120  <<
3239 * ( --- )         ( IP *** )                              C
3240 * Define run-time behavior of definitions compiled/defined
3241 * by a high-level defining definition --
3242 * the FORTH equivalent of a compiler-compiler.
3243 * DOES> assumes that the LATEST symbol table entry
3244 * has at least one word of parameter field,
3245 * which <BUILDS provides.
3246 * Note that DOES> is also not IMMEDIATE.
3247 *
3248 * When the defining word containing DOES> executes the DOES> icode,
3249 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
3250 * overwrites the first word of that symbol's parameter field with its own IP,
3251 * and pops the previous IP from the return stack.
3252 * The icodes which follow DOES> in the stream
3253 * do not execute at the defining word's run-time.
3254 *
3255 * Examining XDOES in the virtual machine shows
3256 * that the defined word will execute those icodes
3257 * which follow DOES> at its own run-time.
3258 *
3259 * The advantage of this kind of behaviour,
3260 * which you will also note in ;CODE,
3261 * is that the defined word can contain
3262 * both operations and data to be operated on.
3263 * This is how FORTH data objects define their own behavior.
3264 *
3265 * Finally, note that the effective parameter field for DOES> definitions
3266 * starts two NATWID words after the CFA, instead of just one
3267 * (four bytes instead of two in a sixteen-bit addressing Forth).
3268 *
3269 * VOCABULARYs will use this. See definition of word FORTH.
3270         FCB     $85
3271         FCC     'DOES'  ; 'DOES>'
3272         FCB     $BE
3273         FDB     BUILDS-10
3274 * DOES  FDB     DOCOL,FROMR,TWOP,LATEST,PFA,STORE
3275 DOES    FDB     DOCOL,FROMR     ; Y/IP is post-inc, needs no adjustment.
3276         FDB     LATEST,PFA,STORE
3277         FDB     PSCODE
3278 *
3279 * ( --- PFA+NATWID )     ( *** IP )
3280 * Characteristic of a DOES> defined word.
3281 * The characteristics of DOES> definitions are written in high-level
3282 * Forth codes rather than native CPU machine level code.
3283 * The first parameter word points to the high-level characteristic.
3284 * This routine's job is to push the IP,
3285 * load the high level characteristic pointer in IP,
3286 * and leave the address following the characteristic pointer on the stack
3287 * so the parameter field can be accessed.
3288 DODOES  LDD     ,S      ; Keep the return address.
3289         STY     ,S      ; Save/nest the current IP on the return stack.
3290         LDY     NATWID,X        ; First parameter is new IP.
3291         LEAX    2*NATWID,X      ; Address of second parameter.
3292         PSHU    X
3293         TFR     D,PC    ; Synthetic return.
3294 *
3295 * From the 6800 model:
3296 * DODOES        LDA IP
3297 *       LDB IP+1
3298 *       LDX     RP      make room on return stack
3299 *       LEAX -1,X       ;
3300 *       LEAX -1,X       ;
3301 *       STX     RP
3302 *       STA 2,X push return address
3303 *       STB 3,X
3304 *       LDX     W       get addr of pointer to run-time code
3305 *       LEAX 1,X        ;
3306 *       LEAX 1,X        ;
3307 *       STX     N       stash it in scratch area
3308 *       LDX     0,X     get new IP
3309 *       STX     IP
3310 *       CLRA    ;               get address of parameter
3311 *       LDB #2
3312 *       ADDB N+1
3313 *       ADCA N
3314 *       PSHS B  ; and push it on data stack
3315 *       PSHS A  ;
3316 *       JMP     NEXT2
3317 *
3318 * ######>> screen 44 <<
3319 * ======>>  121  <<
3320 * ( strptr --- strptr+1 count )
3321 * Convert counted string to string and count.
3322 * (Fetch the byte at strptr, post-increment.)
3323         FCB     $85
3324         FCC     'COUN'  ; 'COUNT'
3325         FCB     $D4
3326         FDB     DOES-8
3327 COUNT   FDB     DOCOL,DUP,ONEP,SWAP,CAT
3328         FDB     SEMIS
3329 *
3330 * ======>>  122  <<
3331 * ( strptr count --- )
3332 * EMIT count characters at strptr.
3333         FCB     $84
3334         FCC     'TYP'   ; 'TYPE'
3335         FCB     $C5
3336         FDB     COUNT-8
3337 TYPE    FDB     DOCOL,DDUP,ZBRAN
3338         FDB     TYPE3-*
3339         FDB     OVER,PLUS,SWAP,XDO
3340 TYPE2   FDB     I,CAT,EMIT,XLOOP
3341         FDB     TYPE2-*
3342         FDB     BRAN
3343         FDB     TYPE4-*
3344 TYPE3   FDB     DROP
3345 TYPE4   FDB     SEMIS
3346 *
3347 * ======>>  123  <<
3348 * ( strptr count1 --- strptr count2 )
3349 * Supress trailing blanks (subtract count of trailing blanks from strptr).
3350         FCB     $89
3351         FCC     '-TRAILIN'      ; '-TRAILING'
3352         FCB     $C7
3353         FDB     TYPE-7
3354 DTRAIL  FDB     DOCOL,DUP,ZERO,XDO
3355 DTRAL2  FDB     OVER,OVER,PLUS,ONE,SUB,CAT,BL
3356         FDB     SUB,ZBRAN
3357         FDB     DTRAL3-*
3358         FDB     LEAVE,BRAN
3359         FDB     DTRAL4-*
3360 DTRAL3  FDB     ONE,SUB
3361 DTRAL4  FDB     XLOOP
3362         FDB     DTRAL2-*
3363         FDB     SEMIS
3364 *
3365 * ======>>  124  <<
3366 * ( --- )
3367 * TYPE counted string out of instruction stream (updating IP).
3368         FCB     $84
3369         FCC     '(."'   ; '(.")'
3370         FCB     $A9
3371         FDB     DTRAIL-12
3372 * PDOTQ FDB     DOCOL,R,TWOP,COUNT,DUP,ONEP
3373 PDOTQ   FDB     DOCOL,R,NATP,COUNT,DUP,ONEP
3374         FDB     FROMR,PLUS,TOR,TYPE
3375         FDB     SEMIS
3376 *
3377 * ======>>  125  <<
3378 * ( --- )                                                 P
3379 * { ." something-to-be-printed " } typical input
3380 * Use WORD to parse to trailing quote;
3381 * if compiling, compile XDOTQ and string parsed,
3382 * otherwise, TYPE string.
3383         FCB     $C2     immediate
3384         FCC     '.'     ; '."'
3385         FCB     $A2
3386         FDB     PDOTQ-7
3387 DOTQ    FDB     DOCOL
3388         FDB     LIT8
3389         FCB     $22     ascii quote
3390         FDB     STATE,AT,ZBRAN
3391         FDB     DOTQ1-*
3392         FDB     COMPIL,PDOTQ,WORD
3393         FDB     HERE,CAT,ONEP,ALLOT,BRAN
3394         FDB     DOTQ2-*
3395 DOTQ1   FDB     WORD,HERE,COUNT,TYPE
3396 DOTQ2   FDB     SEMIS
3397 *
3398 * ######>> screen 45 <<
3399 * ======>>  126  <<== MACHINE DEPENDENT
3400 * ( --- )                 ( *** )
3401 * ( --- IN BLK )          ( anything *** nothing )
3402 * ERROR if parameter stack out of bounds.
3403 *
3404 * But checking whether the stack is in bounds or not
3405 * really should not use the stack.
3406 * And there really should be a ?RSTACK, as well.
3407         FCB     $86
3408         FCC     '?STAC' ; '?STACK'
3409         FCB     $CB
3410         FDB     DOTQ-5
3411 QSTACK  FDB     DOCOL,LIT8
3412 *       FCB     $12
3413         FCB     SINIT-ORIG
3414 * But why use that instead of XSPZER (S0)?
3415 * Multi-user or multi-tasking would not want that.
3416 *       CMPU    <XSPZER
3417 *       FDB     PORIG,AT,TWO,SUB,SPAT,LESS,ONE
3418         FDB     PORIG,AT,SPAT,LESS,ONE  ; Not post-decrement push.
3419         FDB     QERR
3420 * prints 'empty stack'
3421 *
3422 QSTAC2  FDB     SPAT
3423 * Here, we compare with a value at least 128
3424 * higher than dict. ptr. (DICTPT)
3425         FDB     HERE,LIT8
3426         FCB     $80     ; This is a rough check anyway, leave it as is.
3427         FDB     PLUS,LESS,ZBRAN
3428         FDB     QSTAC3-*
3429         FDB     TWO     ; NOT the NATWID constant!
3430         FDB     QERR
3431 * prints 'full stack'
3432 *
3433 QSTAC3  FDB     SEMIS
3434 *
3435 * ======>>  127  <<     this word's function
3436 *           is done by ?STACK in this version
3437 *       FCB     $85
3438 *       FCC     4,?FREE
3439 *       FCB     $C5
3440 *       FDB     QSTACK-9
3441 *QFREE  FDB     DOCOL,SPAT,HERE,LIT8
3442 *       FCB     $80
3443 *       FDB     PLUS,LESS,TWO,QERR,SEMIS        ; This TWO is not NATWID!
3444 *
3445 * ######>> screen 46 <<
3446 * ======>>  128  <<
3447 * ( buffer n --- )
3448 * ***** Check that this is how it works here:
3449 * Get up to n-1 characters from the keyboard,
3450 * storing at buffer and echoing, with backspace editing,
3451 * quitting when a CR is read.
3452 * Terminate it with a NUL.
3453         FCB     $86
3454         FCC     'EXPEC' ; 'EXPECT'
3455         FCB     $D4
3456         FDB     QSTACK-9
3457 EXPECT  FDB     DOCOL,OVER,PLUS,OVER,XDO        ; brace the buffer area
3458 EXPEC2  FDB     KEY,DUP,LIT8
3459         FCB     BACKSP-ORIG
3460         FDB     PORIG,AT,EQUAL,ZBRAN    ; check for backspacing
3461         FDB     EXPEC3-*
3462         FDB     DROP,LIT8
3463         FCB     8       ( backspace character to emit )
3464         FDB     OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS     ; back up TWO characters
3465         FDB     TOR,SUB,BRAN
3466         FDB     EXPEC6-*
3467 EXPEC3  FDB     DUP,LIT8
3468         FCB     $D      ( carriage return )
3469         FDB     EQUAL,ZBRAN
3470         FDB     EXPEC4-*
3471         FDB     LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
3472         FDB     EXPEC5-*
3473 EXPEC4  FDB     DUP
3474 EXPEC5  FDB     I,CSTORE,ZERO,I,ONEP,STORE
3475 EXPEC6  FDB     EMIT,XLOOP
3476         FDB     EXPEC2-*
3477         FDB     DROP
3478         FDB     SEMIS
3479 *
3480 * ======>>  129  <<
3481 * ( --- )
3482 * EXPECT 128 (TWID) characters to TIB.
3483         FCB     $85
3484         FCC     'QUER'  ; 'QUERY'
3485         FCB     $D9
3486         FDB     EXPECT-9
3487 QUERY   FDB     DOCOL,TIB,AT,COLUMS
3488         FDB     AT,EXPECT,ZERO,IN,STORE
3489         FDB     SEMIS
3490 *
3491 * ======>>  130  <<
3492 * ( --- )                                                 P
3493 * End interpretation of a line or screen, and/or prepare for a new block.
3494 * Note that the name of this definition is an empty string,
3495 * so it matches on the terminating NUL in the terminal or block buffer.
3496         FCB     $C1     immediate       < carriage return >
3497         FCB     $80
3498         FDB     QUERY-8
3499 NULL    FDB     DOCOL,BLK,AT,ZBRAN
3500         FDB     NULL2-*
3501         FDB     ONE,BLK,PSTORE
3502         FDB     ZERO,IN,STORE,BLK,AT,BSCR,MOD
3503         FDB     ZEQU
3504 *     check for end of screen
3505         FDB     ZBRAN
3506         FDB     NULL1-*
3507         FDB     QEXEC,FROMR,DROP
3508 NULL1   FDB     BRAN
3509         FDB     NULL3-*
3510 NULL2   FDB     FROMR,DROP
3511 NULL3   FDB     SEMIS
3512 *
3513 * ######>> screen 47 <<
3514 * ======>>  133  <<
3515 * ( adr n b --- )
3516 * Fill n bytes at adr with b.
3517         FCB     $84
3518         FCC     'FIL'   ; 'FILL'
3519         FCB     $CC
3520         FDB     NULL-4
3521 FILL    FDB     DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
3522         FDB     FROMR,ONE,SUB,CMOVE
3523         FDB     SEMIS
3524 *
3525 * ======>>  134  <<
3526 * ( adr n --- )
3527 * Fill n bytes with 0.
3528         FCB     $85
3529         FCC     'ERAS'  ; 'ERASE'
3530         FCB     $C5
3531         FDB     FILL-7
3532 ERASE   FDB     DOCOL,ZERO,FILL
3533         FDB     SEMIS
3534 *
3535 * ======>>  135  <<
3536 * ( adr n --- )
3537 * Fill n bytes with ASCII SPACE.
3538         FCB     $86
3539         FCC     'BLANK' ; 'BLANKS'
3540         FCB     $D3
3541         FDB     ERASE-8
3542 BLANKS  FDB     DOCOL,BL,FILL
3543         FDB     SEMIS
3544 *
3545 * ======>>  136  <<
3546 * ( c --- )
3547 * Format a character at the left of the HLD output buffer.
3548         FCB     $84
3549         FCC     'HOL'   ; 'HOLD'
3550         FCB     $C4
3551         FDB     BLANKS-9
3552 HOLD    FDB     DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
3553         FDB     SEMIS
3554 *
3555 * ======>>  137  <<
3556 * ( --- adr )
3557 * Give the address of the output PAD buffer.
3558 * PAD points to the end of a 68 byte buffer for numeric conversion.
3559         FCB     $83
3560         FCC     'PA'    ; 'PAD'
3561         FCB     $C4
3562         FDB     HOLD-7
3563 PAD     FDB     DOCOL,HERE,LIT8
3564         FCB     $44
3565         FDB     PLUS
3566         FDB     SEMIS
3567 *
3568 * ######>> screen 48 <<
3569 * ======>>  138  <<
3570 * ( c --- )
3571 * Scan a string terminated by the character c or ASCII NUL out of input;
3572 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
3573 * Leading c are passed over, per ENCLOSE.
3574 * Scans from BLK, or from TIB if BLK is zero.
3575 * May overwrite the numeric conversion pad,
3576 * if really long (length > 31) symbols are scanned.
3577         FCB     $84
3578         FCC     'WOR'   ; 'WORD'
3579         FCB     $C4
3580         FDB     PAD-6
3581 WORD    FDB     DOCOL,BLK,AT,ZBRAN
3582         FDB     WORD2-*
3583         FDB     BLK,AT,BLOCK,BRAN
3584         FDB     WORD3-*
3585 WORD2   FDB     TIB,AT
3586 WORD3   FDB     IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
3587         FCB     34
3588         FDB     BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
3589         FDB     CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
3590         FDB     SEMIS
3591 *
3592 * ######>> screen 49 <<
3593 * ======>>  139  <<
3594 * ( d1 string --- d2 adr )
3595 * Convert the text at string into a number, accumulating the result into d1,
3596 * leaving adr pointing to the first character not converted.
3597 * If DPL is non-negative at entry,
3598 * accumulates the number of characters converted into DPL.
3599         FCB     $88
3600         FCC     '(NUMBER'       ; '(NUMBER)'
3601         FCB     $A9
3602         FDB     WORD-7
3603 PNUMB   FDB     DOCOL
3604 PNUMB2  FDB     ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3605         FDB     PNUMB4-*
3606         FDB     SWAP,BASE,AT,USTAR,DROP,ROT,BASE
3607         FDB     AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3608         FDB     PNUMB3-*
3609         FDB     ONE,DPL,PSTORE
3610 PNUMB3  FDB     FROMR,BRAN
3611         FDB     PNUMB2-*
3612 PNUMB4  FDB     FROMR
3613         FDB     SEMIS
3614 *
3615 * ======>>  140  <<
3616 * ( ctstr --- d )
3617 * Convert text at ctstr to a double integer,
3618 * taking the 0 ERROR if the conversion is not valid.
3619 * If a decimal point is present,
3620 * accumulate the count of digits to the decimal point's right into DPL
3621 * (negative DPL at exit indicates single precision).
3622 * ctstr is a counted string
3623 * -- the first byte at ctstr is the length of the string,
3624 * but NUMBER ignores the count and expects a NUL terminator instead.
3625         FCB     $86
3626         FCC     'NUMBE' ; 'NUMBER'
3627         FCB     $D2
3628         FDB     PNUMB-11
3629 NUMB    FDB     DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
3630         FCC     "-"     minus sign
3631         FDB     EQUAL,DUP,TOR,PLUS,LIT,$FFFF
3632 NUMB1   FDB     DPL,STORE,PNUMB,DUP,CAT,BL,SUB
3633         FDB     ZBRAN
3634         FDB     NUMB2-*
3635         FDB     DUP,CAT,LIT8
3636         FCC     "."
3637         FDB     SUB,ZERO,QERR,ZERO,BRAN
3638         FDB     NUMB1-*
3639 NUMB2   FDB     DROP,FROMR,ZBRAN
3640         FDB     NUMB3-*
3641         FDB     DMINUS
3642 NUMB3   FDB     SEMIS
3643 *
3644 * ======>>  141  <<
3645 * ( --- locptr length true )      { -FIND name } typical input
3646 * ( --- false )
3647 * Parse a word, then FIND,
3648 * first in the definition vocabulary,
3649 * then in the CONTEXT (interpretation) vocabulary, if necessary.
3650 * Returns what (FIND) returns, flag and optional location and length.
3651         FCB     $85
3652         FCC     '-FIN'  ; '-FIND'
3653         FCB     $C4
3654         FDB     NUMB-9
3655 DFIND   FDB     DOCOL,BL,WORD,HERE,CONTXT,AT,AT
3656         FDB     PFIND,DUP,ZEQU,ZBRAN
3657         FDB     DFIND2-*
3658         FDB     DROP,HERE,LATEST,PFIND
3659 DFIND2  FDB     SEMIS
3660 *
3661 * ######>> screen 50 <<
3662 * ======>>  142  <<
3663 * ( anything --- nothing )        ( anything *** nothing )
3664 * An indirection for ABORT, for ERROR,
3665 * which may be modified carefully.
3666         FCB     $87
3667         FCC     '(ABORT'        ; '(ABORT)'
3668         FCB     $A9
3669         FDB     DFIND-8
3670 PABORT  FDB     DOCOL,ABORT
3671         FDB     SEMIS
3672 *
3673 * ======>>  143  <<
3674         FCB     $85
3675         FCC     'ERRO'  ; 'ERROR'
3676         FCB     $D2
3677         FDB     PABORT-10
3678 * This really should not be high level, according to best practices.
3679 * But fixing that cascades through MESSAGE,
3680 * requiring re-architecting the disk block system.
3681 * First, we need to get this transliteration running.
3682 ERROR   FDB     DOCOL,WARN,AT,ZLESS
3683         FDB     ZBRAN
3684 * note: WARNING is
3685 * -1 to abort,
3686 * 0 to print error #
3687 * and 1 to print error message from disc
3688         FDB     ERROR2-*
3689         FDB     PABORT
3690 ERROR2  FDB     HERE,COUNT,TYPE,PDOTQ
3691         FCB     4,7     ( bell )
3692         FCC     " ? "
3693         FDB     MESS,SPSTOR,IN,AT,BLK,AT,QUIT
3694         FDB     SEMIS
3695 *
3696 * ======>>  144  <<
3697 * ( symptr --- )
3698 * Print definition's name from its NFA.
3699         FCB     $83
3700         FCC     'ID'    ; 'ID.'
3701         FCB     $AE
3702         FDB     ERROR-8
3703 IDDOT   FDB     DOCOL,PAD,LIT8
3704         FCB     32
3705         FDB     LIT8
3706         FCB     $5F     ( underline )
3707         FDB     FILL,DUP,PFA,LFA,OVER,SUB,PAD
3708         FDB     SWAP,CMOVE,PAD,COUNT,LIT8
3709         FCB     31
3710         FDB     AND,TYPE,SPACE
3711         FDB     SEMIS
3712 *
3713 * ######>> screen 51 <<
3714 * ======>>  145  <<
3715 * ( --- )         { CREATE name } input
3716 * Parse a name (length < 32 characters) and create a header,
3717 * reporting first duplicate found in either the defining vocabulary
3718 * or the context (interpreting) vocabulary.
3719 * Install the header in the defining vocabulary
3720 * with CFA dangerously pointing to the parameter field.
3721 * Leave the name SMUDGEd.
3722         FCB     $86
3723         FCC     'CREAT' ; 'CREATE'
3724         FCB     $C5
3725         FDB     IDDOT-6
3726 CREATE  FDB     DOCOL,DFIND,ZBRAN
3727         FDB     CREAT2-*
3728         FDB     DROP,PDOTQ
3729         FCB     8
3730         FCB     7       ( bel )
3731         FCC     "redef: "
3732         FDB     NFA,IDDOT,LIT8
3733         FCB     4
3734         FDB     MESS,SPACE
3735 CREAT2  FDB     HERE,DUP,CAT,WIDTH,AT,MIN
3736         FDB     ONEP,ALLOT,DUP,LIT8
3737         FCB     ($80|FSMUDG)            ; Bracket the name.
3738         FDB     TOGGLE,HERE,ONE,SUB,LIT8
3739         FCB     $80
3740         FDB     TOGGLE,LATEST,COMMA,CURENT,AT,STORE
3741 *       FDB     HERE,TWOP,COMMA
3742         FDB     HERE,NATP,COMMA
3743         FDB     SEMIS
3744 *
3745 * ######>> screen 52 <<
3746 * ======>>  146  <<
3747 * ( --- )                                         P
3748 *                       { [COMPILE] name } typical use
3749 * -DFIND next WORD and COMPILE it, literally;
3750 * used to compile immediate definitions into words.
3751         FCB     $C9     immediate
3752         FCC     '[COMPILE'      ; '[COMPILE]'
3753         FCB     $DD
3754         FDB     CREATE-9
3755 BCOMP   FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
3756         FDB     SEMIS
3757 *
3758 * ======>>  147  <<
3759 * ( n --- ) if compiling.                          P
3760 * ( n --- n ) if interpreting.
3761 * Compile n as a literal, if compiling.
3762         FCB     $C7     immediate
3763         FCC     'LITERA'        ; 'LITERAL'
3764         FCB     $CC
3765         FDB     BCOMP-12
3766 LITER   FDB     DOCOL,STATE,AT,ZBRAN
3767         FDB     LITER2-*
3768         FDB     COMPIL,LIT,COMMA
3769 LITER2  FDB     SEMIS
3770 *
3771 * ======>>  148  <<
3772 * ( d --- )  if compiling.                        P
3773 * ( d --- d ) if interpreting.
3774 * Compile d as a double literal, if compiling.
3775         FCB     $C8     immediate
3776         FCC     'DLITERA'       ; 'DLITERAL'
3777         FCB     $CC
3778         FDB     LITER-10
3779 DLITER  FDB     DOCOL,STATE,AT,ZBRAN
3780         FDB     DLITE2-*
3781         FDB     SWAP,LITER,LITER        ; Just two literals in the right order.
3782 DLITE2  FDB     SEMIS
3783 *
3784 * ######>> screen 53 <<
3785 * ======>>  149  <<
3786 * ( --- )
3787 * Interpret or compile, according to STATE.
3788 * Searches words parsed in dictionary first, via -FIND,
3789 * then checks for valid NUMBER.
3790 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
3791 * ERROR checks the stack via ?STACK before returning to its caller.
3792         FCB     $89
3793         FCC     'INTERPRE'      ; 'INTERPRET'
3794         FCB     $D4
3795         FDB     DLITER-11
3796 INTERP  FDB     DOCOL
3797 INTER2  FDB     DFIND,ZBRAN
3798         FDB     INTER5-*
3799         FDB     STATE,AT,LESS
3800         FDB     ZBRAN
3801         FDB     INTER3-*
3802         FDB     CFA,COMMA,BRAN
3803         FDB     INTER4-*
3804 INTER3  FDB     CFA,EXEC
3805 INTER4  FDB     BRAN
3806         FDB     INTER7-*
3807 INTER5  FDB     HERE,NUMB,DPL,AT,ONEP,ZBRAN
3808         FDB     INTER6-*
3809         FDB     DLITER,BRAN
3810         FDB     INTER7-*
3811 INTER6  FDB     DROP,LITER
3812 INTER7  FDB     QSTACK,BRAN
3813         FDB     INTER2-*
3814 *       FDB     SEMIS   never executed
3815
3816 *
3817 * ######>> screen 54 <<
3818 * ======>>  150  <<
3819 * ( --- )
3820 * Toggle precedence bit of LATEST definition header.
3821 * During compiling, most symbols scanned are compiled.
3822 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
3823 * but may be compiled via ' (TICK).
3824         FCB     $89
3825         FCC     'IMMEDIAT'      ; 'IMMEDIATE'
3826         FCB     $C5
3827         FDB     INTERP-12
3828 IMMED   FDB     DOCOL,LATEST,LIT8
3829         FCB     FIMMED
3830         FDB     TOGGLE
3831         FDB     SEMIS
3832 *
3833 * ======>>  151  <<
3834 * ( --- )         { VOCABULARY name } input
3835 * Create a vocabulary entry with a flag for terminating vocabulary searches.
3836 * Store the current search context in it for linking.
3837 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
3838         FCB     $8A
3839         FCC     'VOCABULAR'     ; 'VOCABULARY'
3840         FCB     $D9
3841         FDB     IMMED-12
3842 VOCAB   FDB     DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
3843         FDB     COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
3844 * DOVOC FDB     TWOP,CONTXT,STORE
3845 DOVOC   FDB     NATP,CONTXT,STORE
3846         FDB     SEMIS
3847 *
3848 * ======>>  152  <<
3849 *
3850 * Note: FORTH does not go here in the rom-able dictionary,
3851 *    since FORTH is a type of variable.
3852 *
3853 * (Should make a proper architecture for this at some point.)
3854 *
3855 *
3856 * ======>>  153  <<
3857 * ( --- )
3858 * Makes the current interpretation CONTEXT vocabulary
3859 * also the CURRENT defining vocabulary.
3860         FCB     $8B
3861         FCC     'DEFINITION'    ; 'DEFINITIONS'
3862         FCB     $D3
3863         FDB     VOCAB-13
3864 DEFIN   FDB     DOCOL,CONTXT,AT,CURENT,STORE
3865         FDB     SEMIS
3866 *
3867 * ======>>  154  <<
3868 * ( --- )
3869 * Parse out a comment and toss it away.
3870 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
3871         FCB     $C1     immediate       (
3872         FCB     $A8
3873         FDB     DEFIN-14
3874 PAREN   FDB     DOCOL,LIT8
3875         FCC     ")"
3876         FDB     WORD
3877         FDB     SEMIS
3878 *
3879 * ######>> screen 55 <<
3880 * ======>>  155  <<
3881 * ( anything *** nothing )
3882 * Clear return stack.
3883 * Then INTERPRET and, if not compiling, prompt with OK,
3884 * in infinite loop.
3885         FCB     $84
3886         FCC     'QUI'   ; 'QUIT'
3887         FCB     $D4
3888         FDB     PAREN-4
3889 QUIT    FDB     DOCOL,ZERO,BLK,STORE
3890         FDB     LBRAK
3891 *
3892 *  Here is the outer interpretter
3893 *  which gets a line of input, does it, prints " OK"
3894 *  then repeats :
3895 QUIT2   FDB     RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
3896         FDB     ZBRAN
3897         FDB     QUIT3-*
3898         FDB     PDOTQ
3899         FCB     3
3900         FCC     ' OK'   ; ' OK'
3901 QUIT3   FDB     BRAN
3902         FDB     QUIT2-*
3903 *       FDB     SEMIS   ( never executed )
3904 *
3905 * ======>>  156  <<
3906 * ( anything --- nothing )        ( anything *** nothing )
3907 * Clear parameter stack,
3908 * set STATE to interpret and BASE to DECIMAL,
3909 * return to input from terminal,
3910 * restore DRIVE OFFSET to 0,
3911 * print out "Forth-68",
3912 * set interpret and define vocabularies to FORTH,
3913 * and finally, QUIT.
3914 * Used to force the system to a known state
3915 * and return control to the initial INTERPRETer.
3916         FCB     $85
3917         FCC     'ABOR'  ; 'ABORT'
3918         FCB     $D4
3919         FDB     QUIT-7
3920 ABORT   FDB     DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
3921         FCB     8
3922         FCC     "Forth-68"
3923         FDB     FORTH,DEFIN
3924         FDB     QUIT
3925 *       FDB     SEMIS   never executed
3926         PAGE
3927 *
3928 * ######>> screen 56 <<
3929 * bootstrap code... moves rom contents to ram :
3930 * ======>>  157  <<
3931         FCB     $84
3932         FCC     'COL'   ; 'COLD'
3933         FCB     $C4
3934         FDB     ABORT-8
3935 COLD    FDB     *+NATWID
3936 * Ultimately, we want position indepence,
3937 * so I'm using PCR where it seems reasonable.
3938 CENT    LDS     SINIT,PCR       ; Get a useable return stack, at least.
3939         LDA     #IUPDP          ; This is not relative to PC.
3940         TFR     A,DP            ; And a useable direct page, too.
3941         SETDP   IUPDP   ; (For good measure.)
3942 *
3943 * We'll keep this here for the time being.
3944 * There are better ways to do this, of course.
3945 * Re-architect, re-architect.
3946         LEAX    RAM,PCR
3947         STX     <XFENCE ; Borrow this variable for a loop terminator.
3948         LEAY    REND,PCR        ; top of destination
3949         LEAX    ERAM,PCR        ; top of stuff to move
3950 COLD2   LDA     ,-X
3951         STA     ,-Y     ; move TASK & FORTH to ram
3952         CMPX    <XFENCE
3953         BNE     COLD2
3954 *
3955 * CENT  LDS     #REND-1 top of destination
3956 *       LDX     #ERAM   top of stuff to move
3957 * COLD2 LEAX -1,X       ;
3958 *       LDA 0,X
3959 *       PSHS A  ; move TASK & FORTH to ram
3960 *       CMPX    #RAM
3961 *       BNE     COLD2
3962 *
3963 *       LDS     #XFENCE-1       put stack at a safe place for now
3964 *                               But that is taken care of.
3965 *       LDX     COLINT
3966 *       STX     XCOLUM
3967         LDX     COLINT,PCR
3968         STX     <XCOLUM
3969 *       LDX     DELINT
3970 *       STX     XDELAY
3971         LDX     DELINT,PCR
3972         STX     <XDELAY
3973 *       LDX     VOCINT
3974 *       STX     XVOCL
3975         LDX     VOCINT,PCR
3976         STX     <XVOCL
3977 *       LDX     DPINIT
3978 *       STX     XDICTP
3979         LDX     DPINIT,PCR
3980         STX     <XDICTP
3981 *       LDX     FENCIN
3982 *       STX     XFENCE
3983         LDX     FENCIN,PCR
3984         STX     <XFENCE
3985 *
3986 WENT    LDS     SINIT,PCR       ; Get a useable return stack, at least.
3987         LDA     #IUPDP          ; This is not relative to PC.
3988         TFR     A,DP            ; And a useable direct page, too.
3989         SETDP   IUPDP   ; (For good measure.)
3990 *
3991         LEAX    SINIT,PCR
3992         PSHS    X       ; for loop termination
3993         CLRB            ; Yes, I'm being a little ridiculous. Only a little.
3994         TFR     D,Y
3995         LEAY    XFENCE,Y        ; top of destination
3996         LEAX    FENCIN,PCR      ; top of stuff to move
3997 WARM2   LDD     ,--X    ; All entries are 16 bit.
3998         STD     ,--Y
3999         CMPX    ,S
4000         BNE     WARM2
4001         LEAS    2,S     ; But we'll reset the return stack shortly, anyway.
4002 * WENT  LDS     #XFENCE-1       top of destination
4003 *       LDX     #FENCIN         top of stuff to move
4004 * WARM2 LEAX -1,X       ;
4005 *       LDA 0,X
4006 *       PSHS A  ;
4007 *       CMPX    #SINIT
4008 *       BNE     WARM2
4009 *
4010 *       LDS     SINIT
4011 * S is already there.
4012 *       LDX     UPINIT
4013 *       STX     UP              init user ram pointer
4014 * UP is already there (DP).
4015 *       LDX     #ABORT
4016 *       STX     IP
4017         LEAY    ABORT,PCR       ; Prepare IP.
4018 *
4019         NOP             Here is a place to jump to special user
4020         NOP             initializations such as I/0 interrups
4021         NOP
4022 *
4023 * For systems with TRACE:
4024         LDX     #00
4025 *       STX     TRLIM   clear trace mode
4026         STX     <TRLIM  clear trace mode
4027         LDX     #0
4028 *       STX     BRKPT   clear breakpoint address
4029         STX     <BRKPT  clear breakpoint address
4030 *       JMP     RPSTOR+2 start the virtual machine running !
4031         LBSR    RPSTOR+NATWID start the virtual machine running !
4032         LBRA    NEXT    ; But we must also give RP! someplace to return.
4033 *       RP! sets up the return stack pointer, then Y references abort.
4034 *
4035 * Here is the stuff that gets copied to ram :
4036 * (not * at address $140:)
4037 * at an appropriate address:
4038 *
4039 RAM     FDB     $3000,$3000,0,0
4040
4041 * ======>>  (152)  <<
4042 * ( --- )                                                 P
4043 * Makes FORTH the current interpretation vocabulary.
4044 * In order to make this ROMmable, this entry is set up as the tail-end,
4045 * and copied to RAM in the start-up code.
4046 * We want a more elegant solution to this, too. Greedy, maybe.
4047         FCB     $C5     immediate
4048         FCC     'FORT'  ; 'FORTH'
4049         FCB     $C8
4050         FDB     NOOP-7  ; Note that this does not link to COLD!
4051 RFORTH  FDB     DODOES,DOVOC,$81A0,TASK-7
4052         FDB     0
4053         FCC     "(C) Forth Interest Group, 1979"
4054         FCB     $84
4055         FCC     'TAS'   ; 'TASK'
4056         FCB     $CB
4057         FDB     FORTH-8
4058 RTASK   FDB     DOCOL,SEMIS
4059 ERAM    FCC     "David Lion"
4060         PAGE
4061 *
4062 * ######>> screen 57 <<
4063 * ======>>  158  <<
4064 * ( n0 --- d0 )
4065 * Sign extend n0 to a double integer.
4066         FCB     $84
4067         FCC     'S->'   ; 'S->D'
4068         FCB     $C4
4069         FDB     COLD-7  ; Note that this does not link to FORTH (RFORTH)!
4070 STOD    FDB     DOCOL,DUP,ZLESS,MINUS
4071         FDB     SEMIS
4072
4073
4074 *
4075 * ======>>  159  <<
4076 * ( multiplier multiplicand --- product )
4077 * Signed word multiply.
4078         FCB     $81     ; *
4079         FCB     $AA
4080         FDB     STOD-7
4081 STAR    FDB     *+NATWID
4082         LBSR    USTAR+NATWID    ; or [USTAR,PCR]?
4083         LEAU    NATWID,U        ; Drop high word.
4084         RTS
4085 *       JSR     USTARS
4086 *       LEAS 1,S        ;
4087 *       LEAS 1,S        ;
4088 *       JMP     NEXT
4089 *
4090 * ======>>  160  <<
4091 * ( dividend divisor --- remainder quotient )
4092 * M/ in word-only form, i. e., signed division of 2nd word by top word,
4093 * yielding signed word quotient and remainder.
4094         FCB     $84
4095         FCC     '/MO'   ; '/MOD'
4096         FCB     $C4
4097         FDB     STAR-4
4098 SLMOD   FDB     DOCOL,TOR,STOD,FROMR,USLASH
4099         FDB     SEMIS
4100 *
4101 * ======>>  161  <<
4102 * ( dividend divisor --- quotient )
4103 * Signed word divide without remainder.
4104         FCB     $81     ; /
4105         FCB     $AF
4106         FDB     SLMOD-7
4107 SLASH   FDB     DOCOL,SLMOD,SWAP,DROP
4108         FDB     SEMIS
4109 *
4110 * ======>>  162  <<
4111 * ( dividend divisor --- remainder )
4112 * Remainder function, result takes sign of dividend.
4113         FCB     $83
4114         FCC     'MO'    ; 'MOD'
4115         FCB     $C4
4116         FDB     SLASH-4
4117 MOD     FDB     DOCOL,SLMOD,DROP
4118         FDB     SEMIS
4119 *
4120 * ======>>  163  <<
4121 * ( multiplier multiplicand divisor --- remainder quotient )
4122 * Signed precise division of product:
4123 * multiply 2nd and 3rd words on stack
4124 * and divide the 31-bit product by the top word,
4125 * leaving both quotient and remainder.
4126 * Remainder takes sign of product.
4127 * Guaranteed not to lose significant bits in 16 bit integer math.
4128         FCB     $85
4129         FCC     '*/MO'  ; '*/MOD'
4130         FCB     $C4
4131         FDB     MOD-6
4132 SSMOD   FDB     DOCOL,TOR,USTAR,FROMR,USLASH
4133         FDB     SEMIS
4134 *
4135 * ======>>  164  <<
4136 * ( multiplier multiplicand divisor --- quotient )
4137 *   */MOD without remainder.
4138         FCB     $82
4139         FCC     '*'     ; '*/'
4140         FCB     $AF
4141         FDB     SSMOD-8
4142 SSLASH  FDB     DOCOL,SSMOD,SWAP,DROP
4143         FDB     SEMIS
4144 *
4145 * ======>>  165  <<
4146 * ( ud1 u1 --- u2 ud2 )
4147 * U/ with an (unsigned) double quotient.
4148 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
4149 * if you are prepared to deal with the extra 16 bits of result.
4150         FCB     $85
4151         FCC     'M/MO'  ; 'M/MOD'
4152         FCB     $C4
4153         FDB     SSLASH-5
4154 MSMOD   FDB     DOCOL,TOR,ZERO,R,USLASH
4155         FDB     FROMR,SWAP,TOR,USLASH,FROMR
4156         FDB     SEMIS
4157 *
4158 * ======>>  166  <<
4159 * ( n>=0 --- n )
4160 * ( n<0 --- -n )
4161 * Convert the top of stack to its absolute value.
4162         FCB     $83
4163         FCC     'AB'    ; 'ABS'
4164         FCB     $D3
4165         FDB     MSMOD-8
4166 ABS     FDB     DOCOL,DUP,ZLESS,ZBRAN
4167         FDB     ABS2-*
4168         FDB     MINUS
4169 ABS2    FDB     SEMIS
4170 *
4171 * ======>>  167  <<
4172 * ( d>=0 --- d )
4173 * ( d<0 --- -d )
4174 * Convert the top double to its absolute value.
4175         FCB     $84
4176         FCC     'DAB'   ; 'DABS'
4177         FCB     $D3
4178         FDB     ABS-6
4179 DABS    FDB     DOCOL,DUP,ZLESS,ZBRAN
4180         FDB     DABS2-*
4181         FDB     DMINUS
4182 DABS2   FDB     SEMIS
4183 *
4184 * ######>> screen 58 <<
4185 * Disc primitives :
4186 * ======>>  168  <<
4187 * ( --- vadr )
4188 * Least Recently Used buffer.
4189 * Really should be with FIRST and LIMIT in the per-task table.
4190         FCB     $83
4191         FCC     'US'    ; 'USE'
4192         FCB     $C5
4193         FDB     DABS-7
4194 USE     FDB     DOCON
4195         FDB     XUSE
4196 * ======>>  169  <<
4197 * ( --- vadr )
4198 * Most Recently Used buffer.
4199 * Really should be with FIRST and LIMIT in the per-task table.
4200         FCB     $84
4201         FCC     'PRE'   ; 'PREV'
4202         FCB     $D6
4203         FDB     USE-6
4204 PREV    FDB     DOCON
4205         FDB     XPREV
4206 * ======>>  170  <<
4207 * ( buffer1 --- buffer2 f )
4208 * Bump to next buffer,
4209 * flag false if result is PREVious buffer,
4210 * otherwise flag true.
4211 * Used in the LRU allocation routines.
4212         FCB     $84
4213         FCC     '+BU'   ; '+BUF'
4214         FCB     $C6
4215         FDB     PREV-7
4216 PBUF    FDB     DOCOL,LIT8
4217         FCB     $84
4218         FDB     PLUS,DUP,LIMIT,EQUAL,ZBRAN
4219         FDB     PBUF2-*
4220         FDB     DROP,FIRST
4221 PBUF2   FDB     DUP,PREV,AT,SUB
4222         FDB     SEMIS
4223 *
4224 * ======>>  171  <<
4225 * ( --- )
4226 * Mark PREVious buffer dirty, in need of being written out.
4227         FCB     $86
4228         FCC     'UPDAT' ; 'UPDATE'
4229         FCB     $C5
4230         FDB     PBUF-7
4231 UPDATE  FDB     DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
4232         FDB     SEMIS
4233 *
4234 * ======>>  172  <<
4235 * ( --- )
4236 * Mark all buffers empty.
4237 * Standard method of discarding changes.
4238         FCB     $8D
4239         FCC     'EMPTY-BUFFER'  ; 'EMPTY-BUFFERS'
4240         FCB     $D3
4241         FDB     UPDATE-9
4242 MTBUF   FDB     DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
4243         FDB     SEMIS
4244 *
4245 * ======>>  173  <<
4246 * ( --- )
4247 * Clear the current offset to the block numbers in the drive interface.
4248 * The drives need to be re-architected.
4249 * Would be cool to have RAM and ROM drives supported
4250 * in addition to regular physical persistent store.
4251         FCB     $83
4252         FCC     'DR'    ; 'DR0'
4253         FCB     $B0
4254         FDB     MTBUF-16
4255 DRZERO  FDB     DOCOL,ZERO,OFSET,STORE
4256         FDB     SEMIS
4257 *
4258 * ======>>  174  <<== system dependant word
4259 * ( --- )
4260 * Set the current offset in the drive interface to reference the second drive.
4261 * The hard-coded number in there needs to be in a table.
4262         FCB     $83
4263         FCC     'DR'    ; 'DR1'
4264         FCB     $B1
4265         FDB     DRZERO-6
4266 DRONE   FDB     DOCOL,LIT,$07D0,OFSET,STORE
4267         FDB     SEMIS
4268 *
4269 * ######>> screen 59 <<
4270 * ======>>  175  <<
4271 * ( n --- buffer )
4272 * Get a free buffer,
4273 * assign it to block n,
4274 * return buffer address.
4275 * Will free a buffer by writing it, if necessary.
4276 * Does not actually read the block.
4277 * A bug in the fig LRU algorithm, which I have not fixed,
4278 * gives the PREVious buffer if USE gets set to PREVious.
4279 * (The bug is that USE sometimes gets set to PREVious.)
4280 * This bug sometimes causes sector moves to become sector fills.
4281         FCB     $86
4282         FCC     'BUFFE' ; 'BUFFER'
4283         FCB     $D2
4284         FDB     DRONE-6
4285 BUFFER  FDB     DOCOL,USE,AT,DUP,TOR
4286 BUFFR2  FDB     PBUF,ZBRAN
4287         FDB     BUFFR2-*
4288         FDB     USE,STORE,R,AT,ZLESS
4289         FDB     ZBRAN
4290         FDB     BUFFR3-*
4291 *       FDB     R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
4292         FDB     R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
4293 * BUFFR3        FDB     R,STORE,R,PREV,STORE,FROMR,TWOP
4294 BUFFR3  FDB     R,STORE,R,PREV,STORE,FROMR,NATP
4295         FDB     SEMIS
4296 *
4297 * ######>> screen 60 <<
4298 * ======>>  176  <<
4299 * ( n --- buffer )
4300 * Get BUFFER containing block n, relative to OFFSET.
4301 * If block n is not in a buffer, bring it in.
4302 * Returns buffer address.
4303         FCB     $85
4304         FCC     'BLOC'  ; 'BLOCK'
4305         FCB     $CB
4306         FDB     BUFFER-9
4307 BLOCK   FDB     DOCOL,OFSET,AT,PLUS,TOR
4308         FDB     PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
4309         FDB     BLOCK5-*
4310 BLOCK3  FDB     PBUF,ZEQU,ZBRAN
4311         FDB     BLOCK4-*
4312 *       FDB     DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
4313         FDB     DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
4314 BLOCK4  FDB     DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
4315         FDB     BLOCK3-*
4316         FDB     DUP,PREV,STORE
4317 * BLOCK5        FDB     FROMR,DROP,TWOP
4318 BLOCK5  FDB     FROMR,DROP,NATP
4319         FDB     SEMIS
4320 *
4321 * ######>> screen 61 <<
4322 * ======>>  177  <<
4323 * ( line screen --- buffer C/L)
4324 * Bring in the sector containing the specified line of the specified screen.
4325 * Returns the buffer address and the width of the screen.
4326 * Screen number is relative to OFFSET.
4327 * The line number may be beyond screen 4,
4328 * (LINE) will get the appropriate screen.
4329         FCB     $86
4330         FCC     '(LINE' ; '(LINE)'
4331         FCB     $A9
4332         FDB     BLOCK-8
4333 PLINE   FDB     DOCOL,TOR,LIT8
4334         FCB     $40
4335         FDB     BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
4336         FCB     $40
4337         FDB     SEMIS
4338 *
4339 * ======>>  178  <<
4340 * ( line screen --- )
4341 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
4342         FCB     $85
4343         FCC     '.LIN'  ; '.LINE'
4344         FCB     $C5
4345         FDB     PLINE-9
4346 DLINE   FDB     DOCOL,PLINE,DTRAIL,TYPE
4347         FDB     SEMIS
4348 *
4349 * ======>>  179  <<
4350 * ( n --- )
4351 * If WARNING is 0, print "MESSAGE #n";
4352 * otherwise, print line n relative to screen 4,
4353 * the line number may be negative.
4354 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
4355         FCB     $87
4356         FCC     'MESSAG'        ; 'MESSAGE'
4357         FCB     $C5
4358         FDB     DLINE-8
4359 MESS    FDB     DOCOL,WARN,AT,ZBRAN
4360         FDB     MESS3-*
4361         FDB     DDUP,ZBRAN
4362         FDB     MESS3-*
4363         FDB     LIT8
4364         FCB     4
4365         FDB     OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
4366         FDB     MESS4-*
4367 MESS3   FDB     PDOTQ
4368         FCB     6
4369         FCC     'err # '        ; 'err # '
4370         FDB     DOT
4371 MESS4   FDB     SEMIS
4372 *
4373 * ======>>  180  <<
4374 * ( n --- )
4375 * Begin interpretation of screen (block) n.
4376 * See also ARROW, SEMIS, and NULL.
4377         FCB     $84
4378         FCC     'LOA'   ; 'LOAD' :      input:scr #
4379         FCB     $C4
4380         FDB     MESS-10
4381 LOAD    FDB     DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
4382         FDB     BSCR,STAR,BLK,STORE
4383         FDB     INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
4384         FDB     SEMIS
4385 *
4386 * ======>>  181  <<
4387 * ( --- )                                                 P
4388 * Continue interpreting source code on the next screen.
4389         FCB     $C3
4390         FCC     '--'    ; '-->'
4391         FCB     $BE
4392         FDB     LOAD-7
4393 ARROW   FDB     DOCOL,QLOAD,ZERO,IN,STORE,BSCR
4394         FDB     BLK,AT,OVER,MOD,SUB,BLK,PSTORE
4395         FDB     SEMIS
4396         PAGE
4397 *
4398 *
4399 * ######>> screen 63 <<
4400 *    The next 4 subroutines are machine dependent, and are
4401 *    called by words 13 through 16 in the dictionary.
4402 *
4403 * ======>>  182  << code for EMIT
4404 * ( c --- )
4405 * output using rom CHROUT: redirectable to a printer on Coco.
4406 * Outputs the character on stack (low byte of 1 bit word/cell).
4407 PEMIT   PULU    D
4408 PEMITW  TFR     B,A     ; Coco ROM wants it in A.
4409         PSHS    Y,U,DP  ; Save everything important!
4410         CLRB
4411         TFR     B,DP    ; Give the ROM it's direct page.
4412         JSR     [$A002] ; Output the character in A.
4413         PULS    Y,U,DP,PC
4414 * PEMIT STB N   save B
4415 *       STX     N+1     save X
4416 *       LDB ACIAC
4417 *       BITB #2 check ready bit
4418 *       BEQ     PEMIT+4 if not ready for more data
4419 *       STA ACIAD
4420 *       LDX     UP
4421 *       STB IOSTAT-UORIG,X
4422 *       LDB N   recover B & X
4423 *       LDX     N+1
4424 *       RTS             only A register may change
4425 *  PEMIT        JMP     $E1D1   for MIKBUG
4426 *  PEMIT        FCB     $3F,$11,$39     for PROTO
4427 *  PEMIT        JMP     $D286 for Smoke Signal DOS
4428 *
4429 * ======>>  183  << code for KEY
4430 * ( --- c )
4431 * wait for key from POLCAT on Coco.
4432 * Returns the character code for the key pressed.
4433 PKEY    PSHS    Y,U,DP
4434         LDA     #$CF    ; a cursor of sorts
4435         CLRB
4436         TFR     B,DP
4437         SETDP   0
4438         LDX     <$88    ; location
4439         LDB     ,X      ; save glyph
4440         STA     ,X
4441 PKEYLP  JSR     [$A000]
4442         BEQ     PKEYLP
4443         STB     ,X      ; restore
4444 PKEYR   CLRB            ; for the break flag
4445         CMPA    #3      ; break key
4446         BNE     PKEYGT
4447         COMB            ; for the break flag
4448 PKEYGT  EXG     A,B
4449         PSHU    D
4450         PULS    Y,U,DP,PC
4451         SETDP IUPDP
4452 * PKEY  STB N
4453 *       STX     N+1
4454 *       LDB ACIAC
4455 *       ASRB    ;
4456 *       BCC     PKEY+4  no incoming data yet
4457 *       LDA ACIAD
4458 *       ANDA #$7F       strip parity bit
4459 *       LDX     UP
4460 *       STB IOSTAT+1-UORIG,X
4461 *       LDB N
4462 *       LDX     N+1
4463 *       RTS
4464 *  PKEY JMP     $E1AC   for MIKBUG
4465 *  PKEY FCB     $3F,$14,$39     for PROTO
4466 *  PKEY JMP     $D289 for Smoke Signal DOS
4467 *
4468 * ######>> screen 64 <<
4469 * ======>>  184  << code for ?TERMINAL
4470 * ( --- f )
4471 * check break key using POLCAT
4472 * Returns a flag to tell whether the break key was pressed or not.
4473 PQTER   PSHS Y,U,DP
4474         CLRB
4475         TFR B,DP
4476         JSR [$A000]     ; Look but don't wait.
4477         BRA PKEYR
4478 * PQTER LDA ACIAC       Test for 'break'  condition
4479 *       ANDA #$11       mask framing error bit and
4480 *                       input buffer full
4481 *       BEQ     PQTER2
4482 *       LDA ACIAD       clear input buffer
4483 *       LDA #01
4484 * PQTER2        RTS
4485
4486
4487         PAGE
4488 *
4489 * ======>>  185  << code for CR
4490 * ( --- )
4491 * For Coco just output a CR.
4492 * Also subject to redirection in Coco BASIC ROM.
4493 PCR     LDB #$0D
4494         BRA PEMITW
4495 * PCR   LDA #$D carriage return
4496 *       BSR     PEMIT
4497 *       LDA #$A line feed
4498 *       BSR     PEMIT
4499 *       LDA #$7F        rubout
4500 *       LDX     UP
4501 *       LDB XDELAY+1-UORIG,X
4502 * PCR2  DECB    ;
4503 *       BMI     PQTER2  return if minus
4504 *       PSHS B  ; save counter
4505 *       BSR     PEMIT   print RUBOUTs to delay.....
4506 *       PULS B  ;
4507 *       BRA     PCR2    repeat
4508
4509
4510         PAGE
4511 *
4512 * ######>> screen 66 <<
4513 * ======>>  187  <<
4514 * ( ??? )
4515 * Query the disk, I suppose.
4516 * Not sure what the model had in mind for this stub.
4517         FCB     $85
4518         FCC     '?DIS'  ; '?DISC'
4519         FCB     $C3
4520         FDB     ARROW-6
4521 QDISC   FDB     *+NATWID
4522         JMP     NEXT
4523 *
4524 * ######>> screen 67 <<
4525 * ======>>  189  <<
4526 * ( ??? )
4527 * Write one block of data to disk.
4528 * Parameters unspecified in model. Stub in model.
4529         FCB     $8B
4530         FCC     'BLOCK-WRIT'    ; 'BLOCK-WRITE'
4531         FCB     $C5
4532         FDB     QDISC-8
4533 BWRITE  FDB     *+NATWID
4534         JMP     NEXT
4535 *
4536 * ######>> screen 68 <<
4537 * ======>>  190  <<
4538 * ( ??? )
4539 * Read one block of data from disk.
4540 * Parameters unspecified in model. Stub in model.
4541         FCB     $8A
4542         FCC     'BLOCK-REA'     ; 'BLOCK-READ'
4543         FCB     $C4
4544         FDB     BWRITE-14
4545 BREAD   FDB     *+NATWID
4546         JMP     NEXT
4547 *
4548 *The next 3 words are written to create a substitute for disc
4549 * mass memory,located between $3210 & $3FFF in ram.
4550 * ======>>  190.1  <<
4551         FCB     $82
4552         FCC     'L'     ; 'LO'
4553         FCB     $CF
4554         FDB     BREAD-13
4555 LO      FDB     DOCON
4556         FDB     MEMEND  a system dependent equate at front
4557 *
4558 * ======>>  190.2  <<
4559         FCB     $82
4560         FCC     'H'     ; 'HI'
4561         FCB     $C9
4562         FDB     LO-5
4563 HI      FDB     DOCON
4564         FDB     MEMTOP  ( $3FFF or $7FFF in this version )
4565 *
4566 * ######>> screen 69 <<
4567 * ======>>  191  <<
4568 * ( buffer sector f --- )
4569 * Read or Write the specified (absolute -- ignores OFFSET) sector
4570 * from or to the specified buffer.
4571 * A zero flag specifies write,
4572 * non-zero specifies read.
4573 * Sector is an unsigned integer,
4574 * buffer is the buffer's address.
4575 * Will need to use the CoCo ROM disk routines.
4576 * For now, provides a virtual disk in RAM.
4577         FCB     $83
4578         FCC     'R/'    ; 'R/W'
4579         FCB     $D7
4580         FDB     HI-5
4581 RW      FDB     DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
4582         FDB     RW2-*
4583         FDB     PDOTQ
4584         FCB     8
4585         FCC     ' Range ?'      ; ' Range ?'
4586         FDB     QUIT
4587 RW2     FDB     FROMR,ZBRAN
4588         FDB     RW3-*
4589         FDB     SWAP
4590 RW3     FDB     BBUF,CMOVE
4591         FDB     SEMIS
4592 *
4593 * From BIF-6809:
4594 * RW    PSHS Y,U,DP
4595 *       LDY $C006 control table
4596 *       LDX #DROFFS+7   ; This is BIF's table of drive sizes.
4597 *       LDD 2,U
4598 * RWD   SUBD ,X++ sectors
4599 *       BHS RWD
4600 *       BVC RWR table end?
4601 *       LDD #6
4602 *       PSHU D
4603 *       JMP ERROR
4604 * RWR   ADDD ,--X back one
4605 *       PSHS X
4606 *       PSHU D
4607 *       LDD #18 sectors/track
4608 *       PSHU D
4609 *       DOCOL
4610 *       FDB SLAMOD
4611 *       FDB XMACH
4612 *       PULU D
4613 *       STB 2,Y track
4614 *       PULU D
4615 *       INCB
4616 *       STB 3,Y sector
4617 *       PULS D table entry
4618 *       SUBD #DROFFS+7
4619 *       ASRB drive #
4620 *       STB 1,Y
4621 *       LDD 4,U buffer
4622 *       STD 4,Y
4623 *       LDB #2 coco READ
4624 *       LDX ,U 0?
4625 *       BNE *+3
4626 *       INCB coco WRITE
4627 *       STB ,Y op code
4628 *       CLRA
4629 *       TFR A,DP
4630 *       JSR [$C004]     ROM handles timeout
4631 *       PULS Y,U,DP     if IRQ enabled
4632 *       LEAU 6,U
4633 *       LDX $C006
4634 *       LDB 6,X coco status
4635 *       BEQ RWE
4636 *       LDX <UP
4637 *       LDD #0 no disc
4638 *       STD UWARN,X
4639 *       LDD #8
4640 *       PSHU D
4641 *       JMP ERROR
4642 * RWE   NEXT
4643 *
4644 * ######>> screen 72 <<
4645 * ======>>  192  <<
4646 * ( --- ) compiling                                       P
4647 * ( --- adr ) interpreting
4648 * { ' name } input
4649 * Parse a symbol name from input and search the dictionary for it, per -FIND;
4650 * compile the address as a literal if compiling,
4651 * otherwise just push it.
4652         FCB     $C1     immediate
4653         FCB     $A7     '       ( tick )
4654         FDB     RW-6
4655 TICK    FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
4656         FDB     SEMIS
4657 *
4658 * ======>>  193  <<
4659 * ( --- ) { FORGET name } input
4660 * Parse out name of definition to FORGET to, -DFIND it,
4661 * then lop it and everything that follows out of the dictionary.
4662 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
4663         FCB     $86
4664         FCC     'FORGE' ; 'FORGET'
4665         FCB     $D4
4666         FDB     TICK-4
4667 FORGET  FDB     DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
4668         FCB     $18
4669         FDB     QERR,TICK,DUP,FENCE,AT,LESS,LIT8
4670         FCB     $15
4671         FDB     QERR,DUP,ZERO,PORIG,GREAT,LIT8
4672         FCB     $15
4673         FDB     QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
4674         FDB     SEMIS
4675 *
4676 * ######>> screen 73 <<
4677 * ======>>  194  <<
4678 *  ( adr --- )                                             C
4679 * Calculate a back reference from HERE and compile it.
4680         FCB     $84
4681         FCC     'BAC'   ; 'BACK'
4682         FCB     $CB
4683         FDB     FORGET-9
4684 BACK    FDB     DOCOL,HERE,SUB,COMMA
4685         FDB     SEMIS
4686 *
4687 * ======>>  195  <<
4688 * ( --- )   runtime
4689 * typical use: BEGIN code-loop test UNTIL
4690 * typical use: BEGIN code-loop AGAIN
4691 * typical use: BEGIN code-loop test WHILE code-true REPEAT
4692 * ( --- adr n )  compile time                       P,C
4693 * Push HERE for BACK reference for general (non-counting) loops,
4694 * with BEGIN construct flag.
4695 * A better flag: $4245 (ASCII for 'BE').
4696         FCB     $C5
4697         FCC     'BEGI'  ; 'BEGIN'
4698         FCB     $CE
4699         FDB     BACK-7
4700 BEGIN   FDB     DOCOL,QCOMP,HERE,ONE    ; ONE is a flag for BEGIN loops.
4701         FDB     SEMIS
4702 *
4703 * ======>>  196  <<
4704 * ( --- )   runtime
4705 * typical use: test IF code-true ELSE code-false ENDIF
4706 * ENDIF is just a sort of intersection piece,
4707 * marking where execution resumes after both branches.
4708 * ( adr n --- ) compile time
4709 * Check the mark and resolve the IF.
4710 * A better flag: $4846 (ASCII for 'IF').
4711         FCB     $C5
4712         FCC     'ENDI'  ; 'ENDIF'
4713         FCB     $C6
4714         FDB     BEGIN-8
4715 ENDIF   FDB     DOCOL,QCOMP,TWO,QPAIRS,HERE     ; This TWO is a flag for IF.
4716         FDB     OVER,SUB,SWAP,STORE
4717         FDB     SEMIS
4718 *
4719 * ======>>  197  <<
4720 * ( --- )   runtime
4721 * typical use: test IF code-true ELSE code-false ENDIF
4722 * ( adr n --- )
4723 * Alias for ENDIF .
4724         FCB     $C4
4725         FCC     'THE'   ; 'THEN'
4726         FCB     $CE
4727         FDB     ENDIF-8
4728 THEN    FDB     DOCOL,ENDIF
4729         FDB     SEMIS
4730 *
4731 * ======>>  198  <<
4732 * ( limit index --- )   runtime
4733 * typical use: DO code-loop LOOP
4734 * typical use: DO code-loop increment +LOOP
4735 * Counted loop, index is initial value of index.
4736 * Will loop until index equals (positive going)
4737 * or passes (negative going) limit.
4738 *  ( --- adr n )  compile time                        P,C
4739 * Compile (DO), push HERE for BACK reference,
4740 * and push DO control construct flag.
4741 * A better flag: $444F (ASCII for 'DO').
4742         FCB     $C2
4743         FCC     'D'     ; 'DO'
4744         FCB     $CF
4745         FDB     THEN-7
4746 DO      FDB     DOCOL,COMPIL,XDO,HERE,THREE     ; THREE is a flag for DO loops.
4747         FDB     SEMIS
4748 *
4749 * ======>>  199  <<
4750 * ( --- )   runtime
4751 * typical use: DO code-loop LOOP
4752 * Increments the index by one and branches back to beginning of loop.
4753 * Will loop until index equals limit.
4754 * ( adr n --- )  compile time                        P,C
4755 * Check the mark and compile (LOOP), fill in BACK reference.
4756 * A better flag: $444F (ASCII for 'DO').
4757         FCB     $C4
4758         FCC     'LOO'   ; 'LOOP'
4759         FCB     $D0
4760         FDB     DO-5
4761 LOOP    FDB     DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK    ; THREE for DO loops.
4762         FDB     SEMIS
4763 *
4764 * ======>>  200  <<
4765 * ( n --- )   runtime
4766 * typical use: DO code-loop increment +LOOP
4767 * Increments the index by n and branches back to beginning of loop.
4768 * Will loop until index equals (positive going)
4769 * or passes (negative going) limit.
4770 * ( adr n --- )  compile time                       P,C
4771 * Check the mark and compile (+LOOP), fill in BACK reference.
4772 * A better flag: $444F (ASCII for 'DO').
4773         FCB     $C5
4774         FCC     '+LOO'  ; '+LOOP'
4775         FCB     $D0
4776         FDB     LOOP-7
4777 PLOOP   FDB     DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK   ; THREE for DO loops.
4778         FDB     SEMIS
4779 *
4780 * ======>>  201  <<
4781 * ( n --- )   runtime
4782 * typical use: BEGIN code-loop test UNTIL
4783 * Will loop until UNTIL tests true.
4784 * ( adr n --- )  compile time                      P,C
4785 * Check the mark and compile (0BRANCH), fill in BACK reference.
4786 * A better flag: $4245 (ASCII for 'BE').
4787         FCB     $C5
4788         FCC     'UNTI'  ; 'UNTIL' :     ( same as END )
4789         FCB     $CC
4790         FDB     PLOOP-8
4791 UNTIL   FDB     DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK      ; ONE for BEGIN loops.
4792         FDB     SEMIS
4793 *
4794 * ######>> screen 74 <<
4795 * ======>>  202  <<
4796 * ( n --- )   runtime
4797 * typical use: BEGIN code-loop test END
4798 * ( adr n --- )
4799 * Alias for UNTIL .
4800         FCB     $C3
4801         FCC     'EN'    ; 'END'
4802         FCB     $C4
4803         FDB     UNTIL-8
4804 END     FDB     DOCOL,UNTIL
4805         FDB     SEMIS
4806 *
4807 * ======>>  203  <<
4808 * ( --- )   runtime
4809 * typical use: BEGIN code-loop AGAIN
4810 * Will loop forever
4811 * (or until something uses R> DROP to force the current definition to die,
4812 *  or perhaps ABORT or ERROR or some such other drastic means stops things).
4813 * ( adr n --- )  compile time                      P,C
4814 * Check the mark and compile (0BRANCH), fill in BACK reference.
4815 * A better flag: $4245 (ASCII for 'BE').
4816         FCB     $C5
4817         FCC     'AGAI'  ; 'AGAIN'
4818         FCB     $CE
4819         FDB     END-6
4820 AGAIN   FDB     DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK       ; ONE for BEGIN loops.
4821         FDB     SEMIS
4822 *
4823 * ======>>  204  <<
4824 * ( --- )   runtime
4825 * typical use: BEGIN code-loop test WHILE code-true REPEAT
4826 * Will loop until WHILE tests false, skipping code-true on end.
4827 * REPEAT marks where execution resumes after the WHILE find a false flag.
4828 * ( aadr1 n1 adr2 n2 --- )   compile time         P,C
4829 * Check the marks for WHILE and BEGIN,
4830 * compile BRANCH and BACK fill adr1 reference,
4831 * FILL-IN 0BRANCH reference at adr2.
4832 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
4833         FCB     $C6
4834         FCC     'REPEA' ; 'REPEAT'
4835         FCB     $D4
4836         FDB     AGAIN-8
4837 REPEAT  FDB     DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
4838         FDB     TWO,SUB,ENDIF   ; TWO is for IF, 4 is for WHILE.
4839         FDB     SEMIS
4840 *
4841 * ======>>  205  <<
4842 * ( n --- )   runtime
4843 * typical use: test IF code-true ELSE code-false ENDIF
4844 * Will pass execution to the true part on a true flag
4845 * and to the false part on a false flag.
4846 * ( --- adr n )  compile time                       P,C
4847 * Compile a 0BRANCH and dummy offset
4848 * and push IF reference to fill in and
4849 * IF control construct flag.
4850 * A better flag: $4946 (ASCII for 'IF').
4851         FCB     $C2
4852         FCC     'I'     ; 'IF'
4853         FCB     $C6
4854         FDB     REPEAT-9
4855 IF      FDB     DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO  ; TWO is a flag for IF.
4856         FDB     SEMIS
4857 *
4858 * ======>>  206  <<
4859 * ( --- )   runtime
4860 * typical use: test IF code-true ELSE code-false ENDIF
4861 * ELSE is just a sort of intersection piece,
4862 * marking where execution resumes on a false branch.
4863 * ( adr1 n --- adr2 n )  compile time         P,C
4864 * Check the marks,
4865 * compile BRANCH with dummy offset,
4866 * resolve IF reference,
4867 * and leave reference to BRANCH for ELSE.
4868 * A better flag: $4946 (ASCII for 'IF').
4869         FCB     $C4
4870         FCC     'ELS'   ; 'ELSE'
4871         FCB     $C5
4872         FDB     IF-5
4873 ELSE    FDB     DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
4874         FDB     ZERO,COMMA,SWAP,TWO,ENDIF,TWO   ; TWO is a flag for IF.
4875         FDB     SEMIS
4876 *
4877 * ======>>  207  <<
4878 * ( n --- )   runtime
4879 * typical use: BEGIN code-loop test WHILE code-true REPEAT
4880 * Will loop until WHILE tests false, skipping code-true on end.
4881 * ( --- adr n ) compile time                        P,C
4882 * Compile 0BRANCH with dummy offset (using IF),
4883 * push WHILE reference.
4884 * BEGIN flag will sit underneath this.
4885 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
4886         FCB     $C5
4887         FCC     'WHIL'  ; 'WHILE'
4888         FCB     $C5
4889         FDB     ELSE-7
4890 WHILE   FDB     DOCOL,IF,TWOP   ; TWO is a flag for IF, 4 is for WHILE.
4891         FDB     SEMIS
4892 *
4893 * ######>> screen 75 <<
4894 * ======>>  208  <<
4895 * ( count --- )
4896 * EMIT count spaces, for non-zero, non-negative counts.
4897         FCB     $86
4898         FCC     'SPACE' ; 'SPACES'
4899         FCB     $D3
4900         FDB     WHILE-8
4901 SPACES  FDB     DOCOL,ZERO,MAX,DDUP,ZBRAN
4902         FDB     SPACE3-*
4903         FDB     ZERO,XDO
4904 SPACE2  FDB     SPACE,XLOOP
4905         FDB     SPACE2-*
4906 SPACE3  FDB     SEMIS
4907 *
4908 * ======>>  209  <<
4909 * ( --- )
4910 * Initialize HLD for converting a double integer.
4911 * Stores the PAD address in HLD.
4912         FCB     $82
4913         FCC     '<'     ; '<#'
4914         FCB     $A3
4915         FDB     SPACES-9
4916 BDIGS   FDB     DOCOL,PAD,HLD,STORE
4917         FDB     SEMIS
4918 *
4919 * ======>>  210  <<
4920 * ( d --- string length )
4921 * Terminate numeric conversion,
4922 * drop the number being converted,
4923 * leave the address of the conversion string and the length, ready for TYPE.
4924         FCB     $82
4925         FCC     '#'     ; '#>'
4926         FCB     $BE
4927         FDB     BDIGS-5
4928 EDIGS   FDB     DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
4929         FDB     SEMIS
4930 *
4931 * ======>>  211  <<
4932 * ( n d --- d )
4933 * Put sign of n (as a flag) at the head of the conversion string.
4934 * Drop the sign flag.
4935         FCB     $84
4936         FCC     'SIG'   ; 'SIGN'
4937         FCB     $CE
4938         FDB     EDIGS-5
4939 SIGN    FDB     DOCOL,ROT,ZLESS,ZBRAN
4940         FDB     SIGN2-*
4941         FDB     LIT8
4942         FCC     "-"
4943         FDB     HOLD
4944 SIGN2   FDB     SEMIS
4945 *
4946 * ======>>  212  <<
4947 * ( d --- d/base )
4948 * Generate next most significant digit in the conversion BASE,
4949 * putting the digit at the head of the conversion string.
4950         FCB     $81     #
4951         FCB     $A3
4952         FDB     SIGN-7
4953 DIG     FDB     DOCOL,BASE,AT,MSMOD,ROT,LIT8
4954         FCB     9
4955         FDB     OVER,LESS,ZBRAN
4956         FDB     DIG2-*
4957         FDB     LIT8
4958         FCB     7
4959         FDB     PLUS
4960 DIG2    FDB     LIT8
4961         FCC     "0"     ascii zero
4962         FDB     PLUS,HOLD
4963         FDB     SEMIS
4964 *
4965 * ======>>  213  <<
4966 * ( d --- dzero )
4967 * Convert d to a numeric string using # until the result is zero.
4968 * Leave the double result on the stack for #> to drop.
4969         FCB     $82
4970         FCC     '#'     ; '#S'
4971         FCB     $D3
4972         FDB     DIG-4
4973 DIGS    FDB     DOCOL
4974 DIGS2   FDB     DIG,OVER,OVER,OR,ZEQU,ZBRAN
4975         FDB     DIGS2-*
4976         FDB     SEMIS
4977 *
4978 * ######>> screen 76 <<
4979 * ======>>  214  <<
4980 * ( n width --- )
4981 * Print n on the output device in the current conversion base,
4982 * with sign,
4983 * right aligned in a field at least width wide.
4984         FCB     $82
4985         FCC     '.'     ; '.R'
4986         FCB     $D2
4987         FDB     DIGS-5
4988 DOTR    FDB     DOCOL,TOR,STOD,FROMR,DDOTR
4989         FDB     SEMIS
4990 *
4991 * ======>>  215  <<
4992 * ( d width --- )
4993 * Print d on the output device in the current conversion base,
4994 * with sign,
4995 * right aligned in a field at least width wide.
4996         FCB     $83
4997         FCC     'D.'    ; 'D.R'
4998         FCB     $D2
4999         FDB     DOTR-5
5000 DDOTR   FDB     DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
5001         FDB     EDIGS,FROMR,OVER,SUB,SPACES,TYPE
5002         FDB     SEMIS
5003 *
5004 * ======>>  216  <<
5005 * D.      ( d --- )
5006 * Print d on the output device in the current conversion base,
5007 * with sign,
5008 * in free format with trailing space.
5009         FCB     $82
5010         FCC     'D'     ; 'D.'
5011         FCB     $AE
5012         FDB     DDOTR-6
5013 DDOT    FDB     DOCOL,ZERO,DDOTR,SPACE
5014         FDB     SEMIS
5015 *
5016 * ======>>  217  <<
5017 * ( n --- )
5018 * Print n on the output device in the current conversion base,
5019 * with sign,
5020 * in free format with trailing space.
5021         FCB     $81     .
5022         FCB     $AE
5023         FDB     DDOT-5
5024 DOT     FDB     DOCOL,STOD,DDOT
5025         FDB     SEMIS
5026 *
5027 * ======>>  218  <<
5028 * ( adr --- )
5029 * Print signed word at adr, per DOT.
5030         FCB     $81     ?
5031         FCB     $BF
5032         FDB     DOT-4
5033 QUEST   FDB     DOCOL,AT,DOT
5034         FDB     SEMIS
5035 *
5036 * ######>> screen 77 <<
5037 * ======>>  219  <<
5038 * ( n --- )
5039 * Print out screen n as a field of ASCII,
5040 * with line numbers in decimal.
5041         FCB     $84
5042         FCC     'LIS'   ; 'LIST'
5043         FCB     $D4
5044         FDB     QUEST-4
5045 LIST    FDB     DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
5046         FCB     6
5047         FCC     "SCR # "
5048         FDB     DOT,LIT8
5049         FCB     $10
5050         FDB     ZERO,XDO
5051 LIST2   FDB     CR,I,THREE
5052         FDB     DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
5053         FDB     LIST2-*
5054         FDB     CR
5055         FDB     SEMIS
5056 *
5057 * ======>>  220  <<
5058 * ( start end --- )
5059 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
5060 * from start to end.
5061         FCB     $85
5062         FCC     'INDE'  ; 'INDEX'
5063         FCB     $D8
5064         FDB     LIST-7
5065 INDEX   FDB     DOCOL,CR,ONEP,SWAP,XDO
5066 INDEX2  FDB     CR,I,THREE
5067         FDB     DOTR,SPACE,ZERO,I,DLINE
5068         FDB     QTERM,ZBRAN
5069         FDB     INDEX3-*
5070         FDB     LEAVE
5071 INDEX3  FDB     XLOOP
5072         FDB     INDEX2-*
5073         FDB     SEMIS
5074 *
5075 * ======>>  221  <<
5076 * ( n --- )
5077 * List a printer page full of screens.
5078 * Line and screen number are in current base.
5079         FCB     $85
5080         FCC     'TRIA'  ; 'TRIAD'
5081         FCB     $C4
5082         FDB     INDEX-8
5083 TRIAD   FDB     DOCOL,THREE,SLASH,THREE,STAR
5084         FDB     THREE,OVER,PLUS,SWAP,XDO
5085 TRIAD2  FDB     CR,I
5086         FDB     LIST,QTERM,ZBRAN
5087         FDB     TRIAD3-*
5088         FDB     LEAVE
5089 TRIAD3  FDB     XLOOP
5090         FDB     TRIAD2-*
5091         FDB     CR,LIT8
5092         FCB     $0F
5093         FDB     MESS,CR
5094         FDB     SEMIS
5095 *
5096 * ######>> screen 78 <<
5097 * ======>>  222  <<
5098 * ( --- )
5099 * Alphabetically list the definitions in the current vocabulary.
5100         FCB     $85
5101         FCC     'VLIS'  ; 'VLIST'
5102         FCB     $D4
5103         FDB     TRIAD-8
5104 VLIST   FDB     DOCOL,LIT8
5105         FCB     $80
5106         FDB     OUT,STORE,CONTXT,AT,AT
5107 VLIST1  FDB     OUT,AT,COLUMS,AT,LIT8
5108         FCB     32
5109         FDB     SUB,GREAT,ZBRAN
5110         FDB     VLIST2-*
5111         FDB     CR,ZERO,OUT,STORE
5112 VLIST2  FDB     DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
5113         FDB     DUP,ZEQU,QTERM,OR,ZBRAN
5114         FDB     VLIST1-*
5115         FDB     DROP
5116         FDB     SEMIS
5117 *
5118 * ======>>  XX  <<
5119 * ( --- )
5120 * Mostly for place holding.
5121         FCB     $84
5122         FCC     'NOO'   ; 'NOOP'
5123         FCB     $D0
5124         FDB     VLIST-8
5125 NOOP    FDB     NEXT    a useful no-op
5126 ZZZZ    FDB     0,0,0,0,0,0,0,0 end of rom program
5127
5128         PAGE
5129 *  These things, up through the lable 'REND', are overwritten
5130 *  at time of cold load and should have the same contents
5131 *  as shown here:
5132 *
5133 * This can be moved whereever the bottom of the
5134 * user's dictionary is going to be put.
5135 *
5136         FCB     $C5     immediate
5137         FCC     'FORT'  ; 'FORTH'
5138         FCB     $C8
5139         FDB     NOOP-7
5140 FORTH   FDB     DODOES,DOVOC,$81A0,TASK-7
5141         FDB     0
5142 *
5143         FCC     "(C) Forth Interest Group, 1979"
5144
5145         FCB     $84
5146         FCC     'TAS'   ; 'TASK'
5147         FCB     $CB
5148         FDB     FORTH-8
5149 TASK    FDB     DOCOL,SEMIS
5150 *
5151 REND    EQU     *       ( first empty location in dictionary )
5152
5153
5154
5155
5156
5157
5158
5159         PAGE
5160         OPT     L
5161         END