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