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