fig-forth-6809_jmp.asm

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