fig-forth-auto6809opt.asm

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