fig-forth-auto6809.asm

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