runt6800.68c

   1         OPT PRT
   2
   3 * runtimelib FOR 6800
   4 * Joel Matthew Rees April 2020
   5
   6 * Borrowing some concepts from fig-Forth.
   7 * Not tested!
   8
   9 * ------------------------------------LICENSE-------------------------------------
  10 *
  11 * Copyright (c) 2009, 2010, 2011 Joel Matthew Rees
  12 *
  13 * Permission is hereby granted, free of charge, to any person obtaining a copy
  14 * of this software and associated documentation files (the "Software"), to deal
  15 * in the Software without restriction, including without limitation the rights
  16 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  17 * copies of the Software, and to permit persons to whom the Software is
  18 * furnished to do so, subject to the following conditions:
  19 *
  20 * The above copyright notice and this permission notice shall be included in
  21 * all copies or substantial portions of the Software.
  22 *
  23 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  24 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  25 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  26 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  27 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  28 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  29 * THE SOFTWARE.
  30 *
  31 * --------------------------------END-OF-LICENSE----------------------------------
  32 *
  33
  34
  35 * These must be edited for target runtime:
  36
  37 * Necessary here for fake forward referencing:
  38
  39 BYTESZ  EQU 8   ; bit count in byte
  40
  41 ADRWDSZ EQU 2   ; bytes per address word
  42
  43 * If at all possible, a CELL should be able to contain an address.
  44 * Otherwise, fetch and store become oddities.
  45 CELLSZ  EQU ADRWDSZ
  46 CELLBSZ EQU (CELLSZ*BYTESZ)     ; bit count in CELL
  47 DBLSZ   EQU (CELLSZ*2)
  48 DBLBSZ  EQU (DBLSZ*BYTESZ)      ; bit count in DOUBLE
  49
  50 GAPCT   EQU 2   ; address words for the gaps
  51 ALLOGAP EQU (GAPCT*CELLSZ)      ; For crude checks, gaps always zero.
  52
  53
  54 * Declare initial Return Stack (flow-of-control stack):
  55 RSTKBND EQU $8000       ; Bound: one beyond
  56 RSTKINI EQU (RSTKBND-1) ; Init: next available byte on 6800
  57 RSTKSZ  EQU (62*CELLSZ) ; Size: Safe for most purposes.
  58 RSTKLIM EQU (RSTKBND-RSTKSZ)    ; Limit: Last useable
  59 * Kibitzing -- CPUs really should have automatic stack bounds checking.
  60 * Don't forget gaps for CPUs that don't automatically check.
  61 * Crude guard rails is better than none?
  62
  63 * Declare initial Parameter Stack (data stack):
  64 SSTKBND EQU (RSTKLIM-ALLOGAP)
  65 SSTKINI EQU (SSTKBND-CELLSZ)    ; Also post-dec on 6800, but on address word boundary.
  66 SSTKSZ  EQU (126*CELLSZ)        ; Size: CELL addressing, small stacks.
  67 SSTKLIM EQU (SSTKBND-SSTKSZ)
  68
  69 * The paramater stack and heap at opposite ends of the same region
  70 * has mixed benefits.
  71
  72 * The initial per-user allocation heap:
  73 UPGBND  EQU (SSTKLIM-ALLOGAP)
  74 UPGSZ   EQU (64*CELLSZ) ; This will need adjusting in many cases.
  75 UPGBASE EQU (UPGBND-UPGSZ)
  76 UPGINI  EQU UPGBASE
  77
  78
  79 * ORG directives in older assemblers can get tangled up
  80 * if they are convoluted. Keep the ORGs in assending order.
  81
  82
  83         ORG $40
  84
  85 * Internal registers --
  86 * (When switching contexts, these must be saved and restored.):
  87
  88 * RP    RMB ADRWDSZ     ; the return/flow-of-control stack pointer is 6800 S
  89 PSP     RMB ADRWDSZ     ; the parameter/data stack pointer (Forth SP)
  90 UP      RMB ADRWDSZ     ; pointer to the per-task heap
  91 TEMP    RMB 2*CELLSZ    ; for general math
  92 GCOUNT  RMB CELLSZ      ; general counter
  93 IXDEST  RMB ADRWDSZ     ; destination index pointer
  94 IXSRC   RMB ADRWDSZ     ; source index pointer
  95 IXTERM  RMB ADRWDSZ     ; terminator for moves
  96
  97
  98
  99
 100         ORG $100
 101         NOP
 102 COLD    JMP COLDENT
 103         NOP
 104 WARM    JMP WARMENT
 105
 106
 107 * _LOWORD_ Move 256 bytes or less going up:
 108 * 0=256, do not enter without pretesting for 0 count!
 109 * source in IXSRC, destination in IXDEST, count in B:
 110 * Overlaps only work if source is higher than dest.
 111 SMOVEUP
 112         LDX IXSRC
 113         LDAA 0,X
 114         INX
 115         STX IXSRC
 116         LDX IXDEST
 117         STAA 0,X
 118         INX
 119         STX IXDEST
 120         DECB
 121         BNE SMOVEUP
 122         RTS
 123
 124 * _LOWORD_ Move 256 bytes or less going down:
 125 * 0=256, do not enter without pretesting for 0 count!
 126 * source in IXSRC, destination in IXDEST, count in B, A is overwritten:
 127 * Overlaps only work if source is higher than dest.
 128 SMOVEDN
 129         TBA
 130         ADDA IXSRC+1
 131         STAA IXSRC+1
 132         CLRA    ; 1# 2~ -- BCC takes 2#, 4~; INC IXSRC takes 3# & 6~
 133         ADCA IXSRC ; 2# 3~
 134         STAA IXSRC ; 2# 4~
 135         TBA
 136         ADDA IXDEST+1
 137         STAA IXDEST+1
 138         CLRA    ; 1# 2~ -- BCC takes 2#, 4~; INC IXDEST takes 3# & 6~
 139         ADCA IXDEST ; 2# 3~
 140         STAA IXDEST ; 2# 4~
 141 SMOVEDL
 142         LDX IXSRC
 143         DEX
 144         LDAA 0,X
 145         STX IXSRC
 146         LDX IXDEST
 147         DEX
 148         STAA 0,X
 149         STX IXDEST
 150         DECB
 151         BNE SMOVEDL
 152         RTS
 153
 154 * _WORD_ Move up to 32K bytes ( src dest count --- ):
 155 * Copies zero when count >= 2^15
 156 * Compare CMOVE in Forth.
 157 BMOVE
 158         LDX PSP ; get paramaters
 159         LDX 0,X
 160         BEQ DEALL3      ; bail now if zero
 161         BMI DEALL3      ; also if greater than 32K
 162         STX GCOUNT
 163         LDX PSP
 164         LDX CELLSZ,X
 165         LDAA 0,X        ; SRC, going to do math
 166         LDAB 1,X
 167         STAA IXDEST
 168         STAB IXDEST+1
 169         SUBB CELLSZ+ADRWDSZ+1,X ; DEST
 170         SBCA CELLSZ+ADRWDSZ,X
 171         STAB TEMP+1
 172         STAA TEMP
 173         BCS BMOVEDN
 174 BMOVEUP
 175
 176
 177         LDX PSP
 178         LDX CELLSZ+ADRWDSZ,X
 179         STX IXSRC
 180 *
 181         SUBB
 182
 183
 184         LDAB GCOUNT+1   ; Get low byte for partial block
 185         CLR GCOUNT+1    ; To avoid debugging confusion.
 186 BMOVEL  BSR SMOVE       ; partial block and full blocks
 187         DEC GCOUNT      ; count high byte down (blocks)
 188         BPL BMOVEL ; This limits the count.
 189 * Rob point to deallocate 3 on stack, as long as CELLSZ == ADRWDSZ.
 190 DEALL3
 191         LDAB PSP+1      ; 2# 3~
 192         ADDB #(CELLSZ+2*ADRWDSZ)        ; 2# 3~
 193         STAB PSP+1      ; 2# 4~
 194         BCC BMOVEX      ; 2# 4~
 195         INC PSP ; 3# 6~ Unaries have no direct page version. => 11# 20~
 196 BMOVEX  RTS
 197 * DEALL3
 198 *       LDAB PSP+1      ; 2# 3~
 199 *       ADDB #(CELLSZ+2*ADRWDSZ)        ; 2# 3~
 200 *       STAB PSP+1      ; 2# 4~
 201 *       LDAA PSP        ; 2# 3~
 202 *       ADCA #(CELLSZ+2*ADRWDSZ)        ; 2# 3~
 203 *       STAA PSP        ; 2# 4~ => 12# 20~
 204 *       RTS
 205 * DEALL3
 206 *       LDX PSP ; 6 INXs is around the breakover point in the 6800.
 207 *       INX     ; 2 + 6 + 2 bytes => 11#
 208 *       INX     ; 4 + 24 + 5 cycles => 33~
 209 *       INX
 210 *       INX
 211 *       INX
 212 *       INX
 213 *       STX PSP
 214 *       RTS
 215 *
 216
 217 * _LOWORD_ Subtract byte in B from cell pointed to by X:
 218 * Not really all that useful when you can CLRA and SUBCELL?
 219 * SUBBYT
 220 *       LDAA 1,X
 221 *       SBA
 222 *       STAA 1,X
 223 *       BCC ADDBYTX
 224 *       DEC 0,X
 225 * SUBBYTX       RTS
 226
 227 * _LOWORD_ Add byte in B to cell pointed to by X:
 228 * Not really all that useful when you can CLRA and ADDCELL?
 229 * ADDBYT
 230 *       ADDB 1,X
 231 *       STAB 1,X
 232 *       BCC ADDBYTX
 233 *       INC 0,X
 234 * ADDBYTX       RTS
 235
 236
 237 * GETAB MACRO
 238 *       LDX PSP
 239 *       LDAB 1,X
 240 *       LDAA 0,X
 241 *       INX
 242 *       INX
 243 *       STX PSP
 244 *       ENDM
 245 * Or doing as subroutine would would add 4 bytes and about ten cycles?
 246 * How useful would it be?
 247
 248
 249 * _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
 250 AND
 251         LDX PSP
 252         LDAA 0,X
 253         LDAB 1,X
 254         ANDA CELLSZ,X
 255         ANDB CELLSZ+1,X
 256         BRA STDEALL
 257
 258 * _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
 259 OR
 260         LDX PSP
 261         LDAA 0,X
 262         LDAB 1,X
 263         ORAA CELLSZ,X
 264         ORAB CELLSZ+1,X
 265         BRA STDEALL
 266
 267 * _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
 268 XOR
 269         LDX PSP
 270         LDAA 0,X
 271         LDAB 1,X
 272         EORA CELLSZ,X
 273         EORB CELLSZ+1,X
 274         BRA STDEALL
 275
 276 * _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
 277 ADD
 278         LDX PSP ; MACRO GETAB
 279         LDAB CELLSZ+1,X ; n2
 280         LDAA CELLSZ,X
 281 * Fall through:
 282 *
 283 * _LOWORD_ Add cell in A:B to cell pointed to by X:
 284 ADDCELL
 285         ADDB 1,X
 286         ADCA 0,X
 287 * Keep rob point for storing over 2nd and deallocating top.
 288 STDEALL
 289         STAB CELLSZ+1,X
 290         STAA CELLSZ,X
 291         INX     ; deallocate
 292         INX
 293         STX PSP
 294         RTS
 295
 296 * _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
 297 SUB
 298         LDX PSP ; MACRO GETAB
 299         LDAB CELLSZ+1,X
 300         LDAA CELLSZ,X
 301 * Fall through:
 302 *
 303 * !xxx _LOWORD_ Subtract cell pointed to by 2,X from cell in A:B (not useful?):
 304 SUBCELL
 305         SUBB 1,X
 306         SBCA 0,X
 307         BRA STDEALL
 308 *       STAB CELLSZ+1,X
 309 *       STAA CELLSZ,X
 310 *       INX     ; deallocate
 311 *       INX
 312 *       STX PSP
 313 *       RTS
 314
 315 * _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
 316 * (Refer to Forth's C@, but byte is not character!)
 317 BFETCH
 318         LDX PSP
 319         LDX 0,X ; adr
 320         LDAB 1,X
 321         LDX PSP
 322         CLR 0,X
 323         STAB 1,X        ; Not worth robbing.
 324         RTS
 325
 326 * _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
 327 * (Refer to Forth's C!, but byte is not character!)
 328 BSTORE
 329         LDX PSP
 330         LDAB ADRWDSZ+1,X        ; n low byte only
 331         LDX 0,X         ; adr
 332         STAB 0,X        ; Store only byte, do not clear high byte!
 333         BRA DEALL2      ; Rob code to deallocate.
 334
 335 * ASSERT CELLSZ == ADRWDSZ
 336 * _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
 337 FETCH
 338         LDX PSP
 339         LDX 0,X ; adr
 340         LDAA 0,X
 341         LDAB 1,X
 342         LDX PSP
 343         STAA 0,X
 344         STAB 1,X
 345         RTS
 346
 347 * _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
 348 STORE
 349         LDX PSP
 350         LDAA ADRWDSZ,X  ; n
 351         LDAB ADRWDSZ+1,X
 352         LDX 0,X         ; adr
 353         STAA 0,X
 354         STAB 1,X
 355 * Rob point to deallocate 2 on stack.
 356 DEALL2
 357         LDX PSP
 358         INX
 359         INX
 360         INX
 361         INX
 362         STX PSP
 363         RTS
 364
 365 * _WORD_ Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
 366 USTAR
 367         LDX PSP
 368         LDAA #CELLBSZ   ; bits/cell
 369         STAA GCOUNT+1
 370         CLRA
 371         CLRB
 372 USTARL  ROR CELLSZ,X    ; shift multiplier
 373         ROR CELLSZ+1,X
 374         DEC GCOUNT+1    ; done?
 375         BMI USTARX
 376         BCC USTARNA
 377         ADDB CELLSZ+1,X
 378         ADCA CELLSZ,X
 379 USTARNA RORA
 380         RORB ; shift result in
 381         BRA USTARL
 382 USTARX  STAB 1,X        ; store more significant 16 bits
 383         STAA 0,X
 384         RTS
 385
 386 * _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
 387 SWAP
 388         LDX PSP
 389 SWAPROB
 390         LDAA 0,X
 391         LDAB CELLSZ,X
 392         STAB 0,X
 393         STAA CELLSZ,x
 394         LDAA 1,X
 395         LDAB CELLSZ+1,X
 396         STAB 1,X
 397         STAA CELLSZ+1,x
 398         RTS
 399
 400 * _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
 401 * ( ud u --- uremainder uquotient )
 402 * Dividend should be range of product of 16 by 16 bit unsigned multiply,
 403 * divisor should be the multiplier or multiplicand:
 404 USLASH
 405         LDX PSP
 406         LDAA #CELLBSZ+1 ; one more than bits/cell
 407         STAA GCOUNT+1
 408         LDAA CELLSZ,X   ; dividend
 409         LDAB CELLSZ+1,X
 410 USLLUP  CMPA 0,X        ; divisor
 411         BHI USLSUB      ; Make sure carry from LSB would carry over
 412         BCS USLNSUB
 413         CMPB 1,X
 414         BCC USLSUB      ; CC = HS (High or Same)
 415 USLNSUB CLC     ; For shifting
 416         BRA USLNEXT
 417 USLSUB  SUBB 1,X
 418         SBCA 0,X
 419         SEC     ; For shifting
 420 USLNEXT ROL 1+2*CELLSZ,X
 421         ROL 2*CELLSZ,X
 422         DEC GCOUNT+1
 423         BEQ USLX
 424         ROLB
 425         ROLA
 426         BCC USLLUP
 427         BRA USLSUB      ; Catch the excess.
 428 USLX    INX     ; Drop high cell.
 429         INX
 430         STX PSP
 431         STAA 0,X        ; High cell now empty, save remainder.
 432         STAB 1,X        ; But remainder is now top.
 433         BRA SWAPROB     ; PSP in X, reverse quotient & remainder.
 434 * Steal return.
 435
 436
 437 * _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
 438 TOR
 439         LDX PSP
 440         LDAA 0,X
 441         LDAB 1,X
 442         PSHB    ; Watch order!
 443         PSHA
 444         INX     ; Not worth robbing code.
 445         INX
 446         STX PSP
 447         RTS
 448
 449 * _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
 450 RFROM
 451         PULA    ; Watch order
 452         PULB
 453         BRA ALLOSTO
 454
 455 * _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
 456 R
 457         TSX
 458         LDAA 0,X
 459         LDAB 1,X
 460 ALLOSTO
 461         LDX PSP ; allocate
 462         DEX
 463         DEX
 464         STX PSP
 465         STAA 0,X
 466         STAB 1,X
 467         RTS
 468
 469 * Should true be set as 1 or -1?
 470 * _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
 471         LDX PSP
 472
 473         CLR A
 474         CLR B
 475         LDX     0,X
 476         BNE     ZEQU2
 477         INC B
 478 ZEQU2   TSX
 479 *       JMP     STABX
 480
 481
 482
 483 * _LOWORD_ Duplicate (count in B) bytes on stack:
 484 NDUP
 485         LDX PSP
 486         STX TEMP
 487
 488
 489
 490 * _WORD_ Execute the address on the stack:
 491 EXEC
 492         LDX PSP
 493         INX
 494         INX
 495         STX PSP
 496         LDX 0,X
 497         JSR 0,X ; For debugging and flattening, no early optimizations.
 498         RTS
 499
 500
 501
 502 COLDENT EQU *
 503         LDS #RSTKINI
 504         LDX #SSTKINI
 505         STX PSP
 506 WARMENT EQU *
 507         LDS #RSTKINI
 508         LDX #SSTKINI
 509         STX PSP
 510         LDX #UPGINI
 511         STX UP
 512
 513
 514