primitives.
-* ######>> screen 28 <<
-* ======>> 31 <<
- FCB $82
- FCC '0' ; '0='
- FCB $BD
- FDB R-4
-ZEQU FDB *+2
- TSX
- CLR A
- CLR B
- LDX 0,X
- BNE ZEQU2
- INC B
-ZEQU2 TSX
- JMP STABX
*
* ======>> 32 <<
FCB $82
RSTKBND EQU $8000 ; Bound: one beyond
RSTKINI EQU (RSTKBND-1) ; Init: next available byte on 6800
RSTKSZ EQU (62*CELLSZ) ; Size: Safe for most purposes.
-RSTKLIM EQU (RSTKBND-RSTKSZ) ; Limit: Last useable
+RSTKLIM EQU (RSTKBND-RSTKSZ) ; Limit: Last useable (Ignore pre-dec.)
* Kibitzing -- CPUs really should have automatic stack bounds checking.
* Don't forget gaps for CPUs that don't automatically check.
* Crude guard rails is better than none?
+* Declare initial Locals Stack (temporaries stack):
+LSTKBND EQU (RSTKLIM-ALLOGAP)
+LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, even on 6800, but on address word boundary.
+LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM EQU (LSTKBND-LSTKSZ)
+
* Declare initial Parameter Stack (data stack):
-SSTKBND EQU (RSTKLIM-ALLOGAP)
-SSTKINI EQU (SSTKBND-CELLSZ) ; Also post-dec on 6800, but on address word boundary.
+SSTKBND EQU (LSTKLIM-ALLOGAP)
+SSTKINI EQU (SSTKBND-CELLSZ) ; Pre-dec, even on 6800, but on address word boundary.
SSTKSZ EQU (126*CELLSZ) ; Size: CELL addressing, small stacks.
SSTKLIM EQU (SSTKBND-SSTKSZ)
* The initial per-user allocation heap:
UPGBND EQU (SSTKLIM-ALLOGAP)
-UPGSZ EQU (64*CELLSZ) ; This will need adjusting in many cases.
+UPGSZ EQU (30*CELLSZ) ; This will need adjusting in many cases.
UPGBASE EQU (UPGBND-UPGSZ)
UPGINI EQU UPGBASE
* Instead of providing such here, plan on providing funtionality later.
-* _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
AND
LDX PSP
LDAA 0,X
*
* We will assume that auto-in-lining for the 6800 will be not be in this version.
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
OR
LDX PSP
LDAA 0,X
ORAB 1+CELLSZ,X
BRA STDEALL
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
XOR
LDX PSP
LDAA 0,X
LDAA CELLSZ,X
* Fall through:
*
-* _LOWORD_ Add cell in A:B to cell pointed to by X:
+* _LOWORD_ + Add cell in A:B to cell pointed to by X:
ADDCELL
ADDB 1,X
ADCA 0,X
STX PSP
RTS
-* _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+* _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
SUB
LDX PSP ; MACRO GETAB
LDAB 1+CELLSZ,X
* ASSERT CELLSZ == ADRWDSZ
-* _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+* _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
* (Refer to Forth's C@, but byte is not character!)
BFETCH
LDX PSP
STAB 1,X ; Not worth robbing.
RTS
-* _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
* (Refer to Forth's C!, but byte is not character!)
BSTORE
LDX PSP
STAB 0,X ; Store only byte, do not clear high byte!
BRA DEALL2 ; Rob code to deallocate, assumes CELLSZ == ADRWDSZ.
-* _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+* _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
FETCH
LDX PSP
LDX 0,X ; adr
STAB 1,X
RTS
-* _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
STORE
LDX PSP
LDAA ADRWDSZ,X ; n
STX PSP
RTS
-* _WORD_ Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
+* _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
USTAR
LDX PSP
LDAA #CELLBSZ ; bits/cell
STAA 0,X
RTS
-* _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
+* _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
SWAP
LDX PSP
SWAPROB
STAA 1+CELLSZ,x
RTS
-* _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+* _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
* ( ud u --- uremainder uquotient )
* Dividend should be range of product of 16 by 16 bit unsigned multiply,
* divisor should be the multiplier or multiplicand:
BRA SWAPROB ; PSP in X, reverse quotient & remainder.
* Steal return.
-* _WORD_ Save top cell on stack to locals stack ( n --- ) { --- n }:
+* _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
TOL
LDX PSP
LDAA 0,X
STX LSP
RTS
-* _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
+* _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
TOR
LDX PSP
LDAA 0,X
PSHA
JMP 0,X
-* _WORD_ Pop top of locals stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
LFROM
LDX LSP
LDAA 0,X top cell on locals stack
STAB 1,X
RTS
-* _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
RFROM
TSX
LDAA ADRWDSZ,X top cell on R stack -- dodge return address
INS
JMP 0,X ; return
-* _WORD_ Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
L
LDX LSP
LDAA 0,X top cell on locals stack
LDX PSP
BRA DUPST
-* _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R
TSX
LDAA ADRWDSZ,X ; top cell on R stack -- dodge return address
LDX PSP ; allocate
BRA DUPST
-* _WORD_ Duplicate top cell on stack ( n --- n n ):
+* _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
DUP
LDX PSP
LDAA 0,X
STAB 1,X
RTS
+* _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP
+ LDX PSP
+ INX
+ INX
+ STX PSP
+ RTS
+
+* _WORD_ 2DROP Remove two cells from the parameter stack ( d --- )
+DDROP
+ LDX PSP
+ INX
+ INX
+ INX
+ INX
+ STX PSP
+ RTS
+
+
* Should true be set as 1 or -1?
* Going with all bits False (0)
* or all bits True (-1) as the flag to set.
-* _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
+* _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU
LDX PSP
CLRA
COLDENT EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
WARMENT EQU *
LDS #RSTKINI
LDX #SSTKINI
STX PSP
+ LDX #LSTKINI
+ STX LSP
LDX #UPGINI
STX UP
* Don't forget gaps for CPUs that don't automatically check.
* Crude guard rails is better than none?
+* Declare initial Locals Stack (temporaries stack):
+LSTKBND EQU (RSTKLIM-ALLOGAP)
+LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, but on address word boundary.
+LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM EQU (LSTKBND-LSTKSZ)
+
* Declare initial Parameter Stack (data stack):
-SSTKBND EQU (RSTKLIM-ALLOGAP)
+SSTKBND EQU (LSTKLIM-ALLOGAP)
SSTKINI EQU (SSTKBND) ; Also pre-dec, but on address word boundary.
SSTKSZ EQU (126*ADRWDSZ) ; Size: CELL addressing, small stacks.
SSTKLIM EQU (SSTKBND-SSTKSZ)
* The initial per-user allocation heap:
UPGBND EQU (SSTKLIM-ALLOGAP)
-UPGSZ EQU 64*ADRWDSZ ; This will need adjusting in many cases.
+UPGSZ EQU 30*ADRWDSZ ; This will need adjusting in many cases.
UPGBASE EQU (UPGBND-UPGSZ)
UPGINI EQU UPGBASE
* _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
AND
- MOVE.L (ADRWDSZ,A6),D3
+ MOVE.L ADRWDSZ(A6),D3
AND.L (A6)+,D3
MOVE.l D0,(A6)
RTS
* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
OR
- MOVE.L (ADRWDSZ,A6),D3
+ MOVE.L ADRWDSZ(A6),D3
OR.L (A6)+,D3
MOVE.l D0,(A6)
RTS
* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
XOR
- MOVE.L (ADRWDSZ,A6),D3
+ MOVE.L ADRWDSZ(A6),D3
EOR.L (A6)+,D3
MOVE.l D0,(A6)
RTS
-* _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
+* _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
ADD
- MOVE.L (ADRWDSZ,A6),D3
+ MOVE.L ADRWDSZ(A6),D3
ADD.L (A6)+,D3
MOVE.l D0,(A6)
RTS
-* _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+* _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
SUB
- MOVE.L (ADRWDSZ,A6),D3
+ MOVE.L ADRWDSZ(A6),D3
SUB.L (A6)+,D3
MOVE.l D0,(A6)
RTS
-* _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+* _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
* (Refer to Forth's C@, but byte is not character!)
BFETCH
MOVE.L (A6),A1
MOVE.L D3,(A6)
RTS
-* _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( b adr --- ):
+* _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( b adr --- ):
* (Refer to Forth's C!, but byte is not character!)
BSTORE
MOVE.L (A6)+,A1
MOVE.B D3,(A1) ; Store only byte, do not clear high bytes!
RTS
-* _WORD_ Fetch half-cell only pointed to by top cell on stack ( adr --- h(at adr) ):
+* _WORD_ S@ Fetch half-cell only pointed to by top cell on stack ( adr --- h(at adr) ):
* adr must be even address aligned on many 68K.
SFETCH
- MOVE.L (A6).A1
+ MOVE.L (A6),A1
CLR.L D3
MOVE.W (A1),D3
MOVE.L D3,(A6)
RTS
-* _WORD_ Store half-cell at 2nd at address on top of stack, deallocate both ( h adr --- ):
+* _WORD_ S! Store half-cell at 2nd at address on top of stack, deallocate both ( h adr --- ):
* adr must be even address aligned on many 68K.
SSTORE
MOVE.L (A6)+,A1
MOVE.W D3,(A1) ; Store only half-cell, do not clear high half!
RTS
-* _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+* _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
* adr must be even address aligned on many 68K.
FETCH
MOVE.L (A6).A1
MOVE.L D3,(A6)
RTS
-* _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
* adr must be even address aligned on many 68K.
STORE
MOVE.L (A6)+,A1
MOVE.L D3,(A1)
RTS
+* Low confidence in the multiply and divide without an emulator to check.
+
* u1 h1:l1 ADRWDSZ:HALFSZ+ADRWDSZ
* u2 h2:l2 0:HALFSZ
*
-* _WORD_ Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
+* _WORD_ U*bit Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
* Consider bit test instead of shift?
USTARB
- MOVEQ #CELLBSZ,D0 ; bits/cell
+ MOVEQ #CELLBSZ,D0 ; bits/cell -- maybe count is one less for DBcc?
MOVEQ #0,D2 ; Clears carry, not extend
- MOVE.L (ADRWDSZ,A6),D3 ; multiplicand
+ MOVE.L ADRWDSZ(A6),D3 ; multiplicand
MOVE.L (A6),D1 ; multiplier
USTARL
ROXR.L D3
BRA.B USTARX
USTART
BCC.B USTARNA
- ADD.L (ADRWDSZ,A6),D2
+ ADD.L ADRWDSZ(A6),D2
USTARNA RORX.L D2 ; shift result in
BRA USTARL
USTARX MOVEM.L D2/D3,(A6) ; Store result.
* u1 h1:l1 ADRWDSZ:HALFSZ+ADRWDSZ
* u2 h2:l2 0:HALFSZ
*
-* _WORD_ Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) )
-* Using 6809's MUL for speed -- more code less time:
+* _WORD_ U* Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) )
+* Using 68000's MUL for speed.
+* More code, less time, but I need to check that I'm handling the halves right:
USTAR
MOVEQ #0 D1 ; Scratch area for inner products
MOVEQ #0 D0
*
- MOVE.W (HALFSZ+ADRWDSZ,A6),D3 ; low halves
- MULU (HALFSZ,A6),D3
+ MOVE.W HALFSZ+ADRWDSZ(A6),D3 ; low halves
+ MULU HALFSZ(A6),D3
* max: $FFFE0001
*
- MOVE.W (ADRWDSZ,A6),D2 ; inner1: u1 high
- MULU (HALFSZ,A6),D2 ; u2 low
+ MOVE.W ADRWDSZ(A6),D2 ; inner1: u1 high
+ MULU HALFSZ(A6),D2 ; u2 low
* max: $FFFE0001
*
MOVE.W D2,D1 ; lower half of inner1
SWAP D2
MOVE.W D2,D1 ; higher half of inner1, hold it.
*
- MOVE.W (HALFSZ+ADRWDSZ,A6),D2 ; inner2: u1 low
+ MOVE.W HALFSZ+ADRWDSZ(A6),D2 ; inner2: u1 low
MULU (A6),D2 ; u2 high
* max: $FFFE0001
*
MOVE.W D2,D0 ; higher half of inner2
ADD.L D0,D1 ; add to inner1 higher half
* bound: $0000FFFF+$0000FFFF=$0001FFFE
- MOVE.W (ADRWDSZ,A6),D2 ; high halves
+ MOVE.W ADRWDSZ(A6),D2 ; high halves
MULU (A6),D2
* max $FFFE0001
ADD.L D1,D2
MOVEM.L D2/D3,(A6)
RTS
-* _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
+* _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
SWAP
MOVEM.L (A6),D2/D3
EXG D2,D3
* Which will be smaller, faster, less bus activity?
-* _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+* _WORD_ U/MODbit Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
* ( ud u --- uremainder uquotient )
* Dividend should be range of product of 16 by 16 bit unsigned multiply,
* divisor should be the multiplier or multiplicand:
* Consider bit test instead of shift?
-USLASH
- LDA #1+CELLBSZ bit ct
- PSHS A
- LDD ADRWDSZ,U dividend
-USLDIV CMPD ,U divisor
- BHS USLSUB ; *** need to look at this carefully
- ANDCC #^1
- BRA USLBIT
-USLSUB SUBD ,U
- ORCC #1 quotient,
-USLBIT ROL 1+2*ADRWDSZ,U save it
- ROL 2*ADRWDSZ,U
- DEC ,S more bits?
- BEQ USLR
- ROLB remainder
- ROLA
+* Also, examine the native divide again.
+* ** Native divide requires divide-by-zero trap code!
+USLASHB
+ MOVEQ #1+CELLBSZ,D0 ; bit ct
+ MOVEM.L (A6),D3/D2/D1 ; D1 is divisor, D2:D3 is dividend
+USLDIV
+ CMP.L D1,D2 ; dividend high in D2 - divisor in D1
+ BHS.B USLSUB ; *** need to look at this carefully
+ ANDI #^1,CCR ; clear carry bit
+ BRA.B USLBIT
+USLSUB
+ SUB.L D1,D2
+ ORI #1,CCR ; quotient bit,
+USLBIT
+ ROXL.L D3 ; save it
+ SUBQ #1,D0 ; more bits?
+ BEQ.B USLR ; Can DBcc be used here?
+ ROXL.L D2 ; move remainder in as we move dividend out
BCC USLDIV
BRA USLSUB
-USLR LEAS 1,S
- LEAU ADRWDSZ,U
- LDX ADRWDSZ,U
- STD ADRWDSZ,U
- STX ,U
+USLR
+ LEA ADRWDSZ(A6),A6
+ MOVE.L D3,(A6) ; quotient
+ MOVE.L D2,ADRWDSZ(A6) ; remainder
RTS
-**** gotta look at ,S references, work around the PC!
-* Of course, the 68000 has better options than saving temps on the return stack.
-
-* _WORD_ Save top cell on stack to locals stack ( n --- ) { --- n }:
+* _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
TOL
MOVE.L (A4)+,-(A6)
RTS
-* _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
+* _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
TOR
MOVE.L (A7),A1
MOVE.L (A6)+,(A7)
MOVE.L (A6)+,-(A7)
TOR_END
-* _WORD_ Pop top of locals stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
LFROM
MOVE.L (A4)+,-(a6)
RTS
-* _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
RFROM
MOVEM.L (A7)+,A1/A0
MOVE.L A1,-(A6)
MOVEM.L (A7)+,-(A6)
RFROM_END
-* _WORD_ Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
L
MOVE.L (A4),-(a6)
RTS
-* _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R
- MOVE.L (ADRWDSZ,A7),-(A6)
+ MOVE.L ADRWDSZ(A7),-(A6)
RTS
* In-lining:
R_ST
MOVE.L (A7),-(A6)
R_END
+* _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
+DUP
+ MOVE.l (A6),-(A6)
+ RTS
+
+* _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP
+ LEA CELLSZ(A7),A7 ; or PULU D and throw away
+ RTS
+
+* _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
+DDROP
+ LEAU 2*CELLSZ(A7),U ; or PULU D,X and throw away
+ RTS
+
* Should true be set as 1 or -1?
* Going with all bits False (0)
* or all bits True (-1) as the flag to set.
-* _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
+* _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU
MOVE.L (A7),D0
SNE DO
COLDENT EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
WARMENT EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
- LDX #UPGINI
- STX UP
+ MOVE.L #RSTKINI,A7
+ MOVE.L #SSTKINI,A6
+ MOVE.L #LSTKINI,A4
+ MOVE.L #UPGINI,A5
+
* Don't forget gaps for CPUs that don't automatically check.
* Crude guard rails is better than none?
+* Declare initial Locals Stack (temporaries stack):
+LSTKBND EQU (RSTKLIM-ALLOGAP)
+LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, even on 6801, but on address word boundary.
+LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM EQU (LSTKBND-LSTKSZ)
+
* Declare initial Parameter Stack (data stack):
-SSTKBND EQU (RSTKLIM-ALLOGAP)
-SSTKINI EQU (SSTKBND-ADRWDSZ) ; Also post-dec on 6801, but on address word boundary.
+SSTKBND EQU (LSTKLIM-ALLOGAP)
+SSTKINI EQU (SSTKBND-ADRWDSZ) ; Pre-dec, even on 6801, but on address word boundary.
SSTKSZ EQU (126*ADRWDSZ) ; Size: CELL addressing, small stacks.
SSTKLIM EQU (SSTKBND-SSTKSZ)
* The initial per-user allocation heap:
UPGBND EQU (SSTKLIM-ALLOGAP)
-UPGSZ EQU 64*ADRWDSZ ; This will need adjusting in many cases.
+UPGSZ EQU 30*ADRWDSZ ; This will need adjusting in many cases.
UPGBASE EQU (UPGBND-UPGSZ)
UPGINI EQU UPGBASE
* See runt6800.68c for consideration of byte operators and a GETAB routine.
-* _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
AND
LDX PSP
LDD 0,X
*
* We will assume that auto-in-lining for the 6801 will be not be in this version.
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
OR
LDX PSP
LDD 0,X
ORAB 1+CELLSZ,X
BRA STDEALL
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
XOR
LDX PSP
LDD 0,X
EORB 1+CELLSZ,X
BRA STDEALL
-* _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
+* _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
ADD
LDX PSP ; MACRO GETAB
LDD 0,X ; n2
STX PSP
RTS
-* _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+* _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
SUB
LDX PSP ; MACRO GETAB
LDD CELLSZ,X
* ASSERT CELLSZ == ADRWDSZ
-* _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+* _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
* (Refer to Forth's C@, but byte is not character!)
BFETCH
LDX PSP
STAB 1,X ; Not worth robbing.
RTS
-* _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
* (Refer to Forth's C!, but byte is not character!)
BSTORE
LDX PSP
STAB 0,X ; Store only byte, do not clear high byte!
BRA DEALL2 ; Rob code to deallocate, assumes CELLSZ == ADRWDSZ.
-* _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+* _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
FETCH
LDX PSP
LDX 0,X ; adr
STD 0,X
RTS
-* _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
STORE
LDX PSP
LDD ADRWDSZ,X ; n
STD PSP
RTS
-* _WORD_ Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
+* _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
* USTARB
* LDX PSP
* LDAA #CELLBSZ ; bits/cell
* USTARX STD 0,X ; store more significant 16 bits
* RTS
-* _WORD_ Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) )
+* _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) )
* Using 6801's MUL for speed -- more code less time:
USTAR
LDX PSP
STX CELLSZ,X
RTS
-* _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
+* _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
* Use TEMP for speed and code size, since we're using it anyway.
SWAP
LDX PSP
* STAA 1+CELLSZ,x
* RTS
-* _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+* _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
* ( ud u --- uremainder uquotient )
* Dividend should be range of product of 16 by 16 bit unsigned multiply,
* divisor should be the multiplier or multiplicand:
BRA SWAPROB ; PSP in X, reverse quotient & remainder.
* Steal return.
-* _WORD_ Save top cell on stack to locals stack ( n --- ) { --- n }:
+* _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
TOL
LDX PSP
LDD 0,X ; top cell
STX LSP
RTS
-* _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
+* _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
TOR
LDX PSP
LDD 0,X ; top cell
PSHA
JMP 0,X ; return
-* _WORD_ Pop top of parameter stack to locals stack ( --- n ) { n --- }:
+* _WORD_ L> Pop top of parameter stack to locals stack ( --- n ) { n --- }:
LFROM
LDX LSP
LDD 0,X top cell on locals stack
STD 0,X ; save it
RTS
-* _WORD_ Pop top of locals stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ R> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
RFROM
TSX
LDD ADRWDSZ,X top cell on R stack -- dodge return address
INS
JMP 0,X ; return
-* _WORD_ Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
L
LDX LSP
LDD ADRWDSZ,X top cell on locals stack
STD 0,X ; save it
RTS
-* _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R
TSX
LDD ADRWDSZ,X top cell on R stack -- dodge return address
STD 0,X ; save it
RTS
-* _WORD_ Duplicate top cell on stack ( n --- n n ):
+* _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
DUP
LDX PSP
LDD 0,X
STD 0,X
RTS
+* _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP
+ LDX PSP
+ INX ; LDAB #2 1 more byte, 1 less cycle
+ INX ; ABX same cycles
+ STX PSP
+ RTS
+
+* _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
+DDROP
+ LDX PSP
+ LDAB #2*CELLSZ
+ ABX
+ STX PSP
+ RTS
+
+
* Should true be set as 1 or -1?
* Going with all bits False (0)
* or all bits True (-1) as the flag to set.
* D really doesn't help here. (Compare 6800 code.)
-* _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
+* _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU
LDX PSP
LDD 0,X
COLDENT EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
WARMENT EQU *
LDS #RSTKINI
LDX #SSTKINI
STX PSP
+ LDX #LSTKINI
+ STX LSP
LDX #UPGINI
STX UP
* Don't forget gaps for CPUs that don't automatically check.
* Crude guard rails is better than none?
+* Declare initial Locals Stack (temporaries stack):
+LSTKBND EQU (RSTKLIM-ALLOGAP)
+LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, even on 6800, but on address word boundary.
+LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM EQU (LSTKBND-LSTKSZ)
+
* Declare initial Parameter Stack (data stack):
-SSTKBND EQU (RSTKLIM-ALLOGAP)
+SSTKBND EQU (LSTKLIM-ALLOGAP)
SSTKINI EQU (SSTKBND-CELLSZ) ; Also post-dec on 6800, but on address word boundary.
SSTKSZ EQU (126*CELLSZ) ; Size: CELL addressing, small stacks.
SSTKLIM EQU (SSTKBND-SSTKSZ)
* Don't forget gaps for CPUs that don't automatically check.
* Crude guard rails is better than none?
+* Declare initial Locals Stack (temporaries stack):
+LSTKBND EQU (RSTKLIM-ALLOGAP)
+LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, but on address word boundary.
+LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM EQU (LSTKBND-LSTKSZ)
+
* Declare initial Parameter Stack (data stack):
-SSTKBND EQU (RSTKLIM-ALLOGAP)
+SSTKBND EQU (LSTKLIM-ALLOGAP)
SSTKINI EQU (SSTKBND) ; Also pre-dec, but on address word boundary.
SSTKSZ EQU (126*ADRWDSZ) ; Size: CELL addressing, small stacks.
SSTKLIM EQU (SSTKBND-SSTKSZ)
* The initial per-user allocation heap:
UPGBND EQU (SSTKLIM-ALLOGAP)
-UPGSZ EQU 64*ADRWDSZ ; This will need adjusting in many cases.
+UPGSZ EQU 30*ADRWDSZ ; This will need adjusting in many cases.
UPGBASE EQU (UPGBND-UPGSZ)
UPGINI EQU UPGBASE
* RTS ; or whatever
* to bracket the substitution for the interpreter/compiler.
-* _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
AND
LDD CELLSZ,U
ANDA ,U+
STD ,U
RTS
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
OR
LDD CELLSZ,U
ORA ,U+
STD ,U
RTS
-* _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
+* _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
XOR
LDD CELLSZ,U
EORA ,U+
STD ,U
RTS
-* _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
+* _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
ADD
LDD CELLSZ,U ; n1
ADDD ,U++
STD ,U
RTS
-* _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+* _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
SUB
LDD CELLSZ,U ; n1
SUBD ,U++
STD ,U
RTS
-* _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+* _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
* (Refer to Forth's C@, but byte is not character!)
BFETCH
LDB [,U]
STD ,U
RTS
-* _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
* (Refer to Forth's C!, but byte is not character!)
BSTORE
LDB 1+ADRWDSZ,U ; n low byte only
LEAU CELLSZ+ADRWDSZ,U
RTS
-* _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+* _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
FETCH
LDD [,U]
STD ,U
RTS
-* _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+* _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
STORE
LDD ADRWDSZ,U ; n
STD [,U]
* u1 h1:l1 ADRWDSZ:1+ADRWDSZ
* u2 h2:l2 0:1
*
-* _WORD_ Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
+* _WORD_ U*bit Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
* No in-lining.
USTARB
LDA #CELLBSZ ; bits/cell
* u1 h1:l1 ADRWDSZ:1+ADRWDSZ
* u2 h2:l2 0:1
*
-* _WORD_ Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) )
+* _WORD_ U* Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) )
* Using 6809's MUL for speed -- more code less time:
* No in-lining.
USTAR
RTS
-* _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
+* _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
SWAP
- LDX ,U
- LDD ADRWDSZ,U
- STD ,U
- STX ADRWDSZ,U
+ PULU D,X
+ PSHU D
+ PSHU X
+* LDX ADRWDSZ,U
+* LDD ,U
+* STD ADRWDSZ,U
+* STX ,U
RTS
-* _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+* _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
* ( ud u --- uremainder uquotient )
* Dividend should be range of product of 16 by 16 bit unsigned multiply,
* divisor should be the multiplier or multiplicand:
**** gotta look at ,S references one more time
-* _WORD_ Save top cell on stack to locals stack ( n --- ) { --- n }:
+* _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
TOL
PULU D
LDX <LSP
STX <LSP
RTS
-* _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
+* _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
TOR
LDX ,S ; return address, oh forgetful one!
PULU D
PSHS D
TOR_M_END
-* _WORD_ Pop top of return stack to locals stack ( --- n ) { n --- }:
+* _WORD_ L> Pop top of return stack to locals stack ( --- n ) { n --- }:
LFROM
LDX <LSP
LDD ,X++
PSHU D
RTS
-* _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
+* _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
RFROM
PULS D,X
PSHU X
PSHU X
RFROM_M_END
-* _WORD_ Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
L
LDX <LSP
LDD ,X
PSHU D
RTS
-* _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+* _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R
LDD ADRWDSZ,S
PSHU D
PSHU D
R_M_END
-* _WORD_ Duplicate top cell on stack ( n --- n n ):
+* _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
DUP
LDD ,U
PSHU D
RTS
+* _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP
+ LEAU CELLSZ,U ; or PULU D and throw away
+ RTS
+
+* _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
+DDROP
+ LEAU 2*CELLSZ,U ; or PULU D,X and throw away
+ RTS
+
* Should true be set as 1 or -1?
* Going with all bits False (0)
* or all bits True (-1) as the flag to set.
* D really doesn't help much here. (Compare 6800 code.)
-* _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
+* _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU
LDD ,U
BNE ZEQUF
COLDENT
- LDS #RSTKINI
- LDU #SSTKINI
WARMENT
LDS #RSTKINI
LDU #SSTKINI
+ LDX #LSTKINI
+ STX LSP
LDX #UPGINI
* STX UP
OPT PRT
-; runtimelib FOR 8080
+; runtimelib FOR 8080 using HL as the parameter stack pointer
; Joel Matthew Rees September 2020
; Borrowing some concepts from fig-Forth.
; Declare initial Return Stack (flow-of-control stack):
RSTKBND: EQU 08000H ; Bound: one beyond
-RSTKINI: EQU (RSTKBND-1) ; Init: 8080? next available byte on 6800
+RSTKINI: EQU (RSTKBND-1) ; Init: 8080? last pushed, IIRC
RSTKSZ: EQU (62*CELLSZ) ; Size: Safe for most purposes.
RSTKLIM: EQU (RSTKBND-RSTKSZ) ; Limit: Last useable
; Kibitzing -- CPUs really should have automatic stack bounds checking.
; Don't forget gaps for CPUs that don't automatically check.
; Crude guard rails is better than none?
+; Declare initial Locals Stack (temporaries stack):
+LSTKBND: EQU (RSTKLIM-ALLOGAP)
+LSTKINI: EQU (LSTKBND-CELLSZ) ; 8080? pre-dec, but on address word boundary.
+LSTKSZ: EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM: EQU (LSTKBND-LSTKSZ)
+
; Declare initial Parameter Stack (data stack):
-SSTKBND: EQU (RSTKLIM-ALLOGAP)
-SSTKINI: EQU (SSTKBND-CELLSZ) ; 8080? post-dec on 6800, but on address word boundary.
+SSTKBND: EQU (LSTKLIM-ALLOGAP)
+SSTKINI: EQU (SSTKBND-CELLSZ) ; 8080? pre-dec, but on address word boundary.
SSTKSZ: EQU (126*CELLSZ) ; Size: CELL addressing, small stacks.
SSTKLIM: EQU (SSTKBND-SSTKSZ)
; The initial per-user allocation heap:
UPGBND: EQU (SSTKLIM-ALLOGAP)
-UPGSZ: EQU (64*CELLSZ) ; This will need adjusting in many cases.
+UPGSZ: EQU (30*CELLSZ) ; This will need adjusting in many cases.
UPGBASE: EQU (UPGBND-UPGSZ)
UPGINI: EQU UPGBASE
; (When switching contexts, these must be saved and restored.):
; RP: EQU SP ; ?? ; the return/flow-of-control stack pointer is 8080 SP
+LSP: DS ADRWDSZ ; the locals stack pointer (for locals, i. e., instead of RP)
; PSP: EQU HL ; the parameter/data stack pointer (Forth SP)
UP: DS ADRWDSZ ; pointer to the per-task heap -- BC?
; TEMP: DS 2*CELLSZ ; for general math
; Using HL for the parameter stack pointer means that
; interrupts must *not* use the interrupted routine's parameter stack.
;
-; If we used DE as the stack pointer, it could remain constant while HL indexed the stack.
+; If we used DE as the parameter stack pointer,
+; it could remain constant while HL indexed the stack.
; But since we are indexing the stack with the stack pointer itself,
; the stack pointer will often be out of position to protect the active contents.
;
; We could gamble and guess that six bytes or sixteen would be enough to avoid active stack,
; but it will be better to just have the interrupt routines set their own parameter stacks.
;
-; Note that using DE as the stack pointer would not mean we could use XCHG
+; Note that using DE as the parameter stack pointer would not mean we could use XCHG
; to save the current pointer and index the stack, for reasons evident from the above.
+;
+; Note also the probable convenience of being able to index the stack pointer.
+;
+; I want to use DE for the locals stack pointer with HL as the parameter stack pointer,
+; but that makes it unavailable as your first temporary,
+; and temporaries are precisely what the local stack is for.
+;
+; Re-writing to use DE as the parameter stack pointer might be a worthwhile exercise?
; ****
; How useful would it be?
-LOGOP: MACRO OP0 ; hides a lot of cycles and object code
+LOGOP: MACRO OP0, OP1 ; hides a lot of cycles and object code
MOV A,M
INX HL
INX HL
MOV A,M
INX HL
INX HL
- OP0 M ; more significant byte on 8080
+ OP1 M ; more significant byte on 8080
DCX HL
RET
ENDM
-; _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
-AND: LOGOP ANA
+; _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
+AND: LOGOP ANA, ANA
-; _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
-OR: LOGOP ORA
+; _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
+OR: LOGOP ORA, ORA
-; _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
-XOR: LOGOP XRA
+; _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
+XOR: LOGOP XRA, XRA
-; _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
-ADD: STC ; clear carry (LSB first required!)
- CMC ; So we don't have to rewrite all of LOGOP
- LOGOP ADC ; to use ADD first and ADC second.
+; _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
+ADD:
+ LOGOP ADD, ADC
+; STC ; clear carry (LSB first required!)
+; CMC ; So we don't have to rewrite all of LOGOP
+; LOGOP ADC ; to use ADD first and ADC second.
-; _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
-SUB: STC ; clear carry (See ADD.)
- CMC
- LOGOP SBB
+; _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+SUB:
+ LOGOP SUB, SBB
+; STC ; clear carry (See ADD.)
+; CMC
+; LOGOP SBB
-; _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+; _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
; (Refer to Forth's C@, but byte is not character!)
BFETCH: MOV C,M
INX HL
MOV M,A ; Store byte
RET ; PSP unchanged
-; _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+; _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
; (Refer to Forth's C!, but byte is not character!)
BSTORE: MOV C,M ; address low byte
INX HL
RET
; ASSERT CELLSZ == ADRWDSZ
-; _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+; _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
FETCH: MOV C,M
INX HL
MOV B,M
MOV M,A ; Store it.
RET ; PSP unchanged
-; _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+; _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
STORE: MOV C,M ; address low byte
INX HL
MOV B,M ; address high byte
RET
-; _WORD_ Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
+; _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
USTAR: MOV E,M ; multiplier
INX HL
MOV D,M
MOV M,B ;
RET
-; _WORD_ swap top two cells on stack ( n1 n2 --- n2 n1 ):
+; _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
SWAP: MOV C,M
INX HL
MOV B,M
MOV M,D
RET
-; _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+; _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
; ( ud u --- uremainder uquotient )
; Dividend should be range of product of 16 by 16 bit unsigned multiply,
; divisor should be the multiplier or multiplicand in such multiply:
DCX HL ; count
DCR M
INX HL
- BEQ USLX
+ JZ USLX
MOV A,C
RAL
MOV C,A
MOV M,B ; quotient high byte
RET
- LDX PSP
- LDAA #CELLBSZ+1 ; one more than bits/cell
- STAA GCOUNT+1
- LDAA CELLSZ,X ; dividend
- LDAB CELLSZ+1,X
-USLLUP: CMPA 0,X ; divisor
- BHI USLSUB ; Make sure carry from LSB would carry over
- BCS USLNSUB
- CMPB 1,X
- BCC USLSUB ; CC = HS (High or Same)
-USLNSUB: CLC ; For shifting
- BRA USLNEXT
-USLSUB: SUBB 1,X
- SBCA 0,X
- SEC ; For shifting
-USLNEXT: ROL 1+2*CELLSZ,X
- ROL 2*CELLSZ,X
- DEC GCOUNT+1
- BEQ USLX
- ROLB
- ROLA
- BCC USLLUP
- BRA USLSUB ; Catch the excess.
-USLX: INX ; Drop high cell.
- INX
- STX PSP
- STAA 0,X ; High cell now empty, save remainder.
- STAB 1,X ; But remainder is now top.
- BRA SWAPROB ; PSP in X, reverse quotient & remainder.
-; Steal return.
-
+; _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
+TOL: MOV C,M ; low byte first
+ INX HL
+ MOV B,M
+ INX HL
+ PUSH HL ; save PSP for a moment because we need LSP
+ LHLD LSP
+ DCX HL
+ MOV M,B ; high byte, then low byte
+ DCX HL
+ MOV M,C
+ SHLD LSP
+ POP HL ; bring PSP back
+ RET
-; _WORD_ Save top cell on stack to return stack ( n --- ) { --- n }:
+; _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
TOR: MOV C,M
INX HL
MOV B,M
; Note that using either PCHL or XTHL
; would require making DE the parameter stack.
-; _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
+; _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
+LFROM: PUSH HL ; save PSP for a moment because we need LSP
+ LHLD LSP
+ MOV C,M ; low byte first
+ INX HL
+ MOV B,M
+ INX HL
+ SHLD LSP
+ POP HL ; restore PSP
+ DCX HL
+ MOV M,B ; high byte, then low
+ DCX HL
+ MOV M,C
+ RET
+
+; _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
RFROM: POP BC
POP DE
DCX HL
PUSH BC
RET ; Too bad HL is busy being the parameter stack.
-; _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+; _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+L: PUSH HL ; save PSP for a moment because we need LSP
+ LHLD LSP
+ MOV C,M ; low byte first
+ INX HL
+ MOV B,M ; But do NOT update!
+ POP HL ; restore PSP (Good code robbing point?)
+ DCX HL
+ MOV M,B ; high byte, then low
+ DCX HL
+ MOV M,C
+ RET
+
+
+; _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R: POP BC
- POP DE
- PUSH DE
+ POPE
+ PUSHE
PUSH BC
DCX HL
MOV M,D
MOV M,E
RET
+; _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
+DUP: MOV C,M ; Low byte first
+ INX HL
+ MOV B,M
+ DCX HL
+ DCX HL ; room for duplicate high (Could steal below from LFROM?)
+ MOV M,B
+ DCX HL
+ MOV M,C ; low
+ RET
+
+; _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP: INX HL
+ INX HL
+ RET
+
+; _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
+DDROP: INX HL
+ INX HL
+ INX HL
+ INX HL
+ RET
+;
+; Probably takes more bytes and cycles?
+; LXI BC,4
+; DAD BC
+; RTS
+; Or
+; CALL DROP
+; JMP DROP
+; Etc.
* Should true be set as 1 or -1?
* Going with all bits False (0)
* or all bits True (-1) as the flag to set.
-* _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
+* _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU: MOV A,M
INX HL
ORA M
- BNZ ZEQUF
+ JNZ ZEQUF
CMA ; 0 => -1
JMP ZEQUD
ZEQUF: XRA A
* MOV A,M
* INX HL
* ORA M
-* BNZ ZEQUF
+* JNZ ZEQUF
* INR A ; 0 => 1
* JMP ZEQUD
* ZEQUF: XRA A
GMVPRM:
LDX PSP ; get paramaters for move
LDX 0,X ; count
- BEQ GMVPRX ; bail now if zero
+ JZ GMVPRX ; bail now if zero
BMI GMVPRX ; also if greater than 32K
STX GCOUNT
LDX PSP
-COLDENT: EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
-WARMENT: EQU *
- LDS #RSTKINI
- LDX #SSTKINI
- STX PSP
- LDX #UPGINI
- STX UP
+COLDENT: LXI SP,RSTKINI
+ LXI HL,LSTKINI
+ SHLD LSP
+ LXI HL,UPGINI
+ SHLD UP
+ LXI HL,SSTKINI ; PSP
+WARMENT: EQU COLDENT
OPT PRT
-; runtimelib FOR 8080
+; runtimelib FOR 8080 using DE as the parameter stack pointer
; Joel Matthew Rees September 2020
; Borrowing some concepts from fig-Forth.
; Not tested!
+; In fact, I was never all that good with 8080 code,
+; and it has been almost 40 years, so ...
+; don't expect it to work without fixing it.
+; Patterned after 6800 libs.
; ------------------------------------LICENSE-------------------------------------
;
; IXSRC: DS ADRWDSZ ; source index pointer
; IXTERM: DS ADRWDSZ ; terminator for moves
+; ****
+; Any
+; Using DE for the parameter stack pointer means that
+; interrupts must *not* use the interrupted routine's parameter stack.
+;
+; If we used DE as the stack pointer, it could remain constant while HL indexed the stack.
+; But since we are indexing the stack with the stack pointer itself,
+; the stack pointer will often be out of position to protect the active contents.
+;
+; We could gamble and guess that six bytes or sixteen would be enough to avoid active stack,
+; but it will be better to just have the interrupt routines set their own parameter stacks.
+;
+; Note that using DE as the stack pointer would not mean we could use XCHG
+; to save the current pointer and index the stack, for reasons evident from the above.
+; ****
--- /dev/null
+; OPT PRT
+
+; runtimelib FOR 8080 using HL as the parameter stack pointer
+; Joel Matthew Rees September 2020
+
+; Borrowing some concepts from fig-Forth.
+; Not tested!
+; In fact, I was never all that good with 8080 code,
+; and it has been almost 40 years, so ...
+; don't expect it to work without fixing it.
+; Patterned after 6800 libs.
+
+; ------------------------------------LICENSE-------------------------------------
+;
+; Copyright (c) 2020 Joel Matthew Rees
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+; THE SOFTWARE.
+;
+; --------------------------------END-OF-LICENSE----------------------------------
+;
+
+
+; These must be edited for target runtime:
+
+; Necessary here for fake forward referencing:
+
+; Watch label width, 5 significant characters on original 8080
+
+BYTESZ: EQU 8 ; bit count in byte
+
+ADRWDSZ: EQU 2 ; bytes per address word
+
+; If at all possible, a CELL should be able to contain an address.
+; Otherwise, fetch and store become oddities.
+CELLSZ: EQU ADRWDSZ
+CELLBSZ: EQU (CELLSZ*BYTESZ) ; bit count in CELL
+DBLSZ: EQU (CELLSZ*2)
+DBLBSZ: EQU (DBLSZ*BYTESZ) ; bit count in DOUBLE
+
+GAPCT: EQU 2 ; address words for the gaps
+ALLOGAP: EQU (GAPCT*CELLSZ) ; For crude checks, gaps always zero.
+
+
+; Declare initial Return Stack (flow-of-control stack):
+RSTKBND: EQU 08000H ; Bound: one beyond
+RSTKINI: EQU (RSTKBND-1) ; Init: 8080? next available byte on 6800
+RSTKSZ: EQU (62*CELLSZ) ; Size: Safe for most purposes.
+RSTKLIM: EQU (RSTKBND-RSTKSZ) ; Limit: Last useable
+; Kibitzing -- CPUs really should have automatic stack bounds checking.
+; Don't forget gaps for CPUs that don't automatically check.
+; Crude guard rails is better than none?
+
+; Declare initial Locals Stack (temporaries stack):
+LSTKBND: EQU (RSTKLIM-ALLOGAP)
+LSTKINI: EQU (LSTKBND-CELLSZ) ; 8080? pre-dec, but on address word boundary.
+LSTKSZ: EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
+LSTKLIM: EQU (LSTKBND-LSTKSZ)
+
+; Declare initial Parameter Stack (data stack):
+SSTKBND: EQU (LSTKLIM-ALLOGAP)
+SSTKINI: EQU (SSTKBND-CELLSZ) ; 8080? post-dec on 6800, but on address word boundary.
+SSTKSZ: EQU (126*CELLSZ) ; Size: CELL addressing, small stacks.
+SSTKLIM: EQU (SSTKBND-SSTKSZ)
+
+; The paramater stack and heap at opposite ends of the same region
+; has mixed benefits.
+
+; The initial per-user allocation heap:
+UPGBND: EQU (SSTKLIM-ALLOGAP)
+UPGSZ: EQU (30*CELLSZ) ; This will need adjusting in many cases.
+UPGBASE: EQU (UPGBND-UPGSZ)
+UPGINI: EQU UPGBASE
+
+
+; ORG directives in older assemblers can get tangled up
+; if they are convoluted.
+; Keep the ORGs in ascending order.
+
+
+; ORG 040H ; 8080?
+RESET: JMP COLD
+ DS 0EDH
+
+
+; Internal registers --
+; (When switching contexts, these must be saved and restored.):
+
+; RP: EQU SP ; ?? ; the return/flow-of-control stack pointer is 8080 SP
+LSP: DS ADRWDSZ ; the locals stack pointer (for locals, i. e., instead of RP)
+; PSP: EQU HL ; the parameter/data stack pointer (Forth SP)
+UP: DS ADRWDSZ ; pointer to the per-task heap -- BC?
+; TEMP: DS 2*CELLSZ ; for general math
+; GCOUNT: DS CELLSZ ; general counter
+; IXDEST: DS ADRWDSZ ; destination index pointer
+; IXSRC: DS ADRWDSZ ; source index pointer
+; IXTERM: DS ADRWDSZ ; terminator for moves
+
+; ****
+; Using HL for the parameter stack pointer means that
+; interrupts must *not* use the interrupted routine's parameter stack.
+;
+; If we used DE as the parameter stack pointer,
+; it could remain constant while HL indexed the stack.
+; But since we are indexing the stack with the stack pointer itself,
+; the stack pointer will often be out of position to protect the active contents.
+;
+; We could gamble and guess that six bytes or sixteen would be enough to avoid active stack,
+; but it will be better to just have the interrupt routines set their own parameter stacks.
+;
+; Note that using DE as the parameter stack pointer would not mean we could use XCHG
+; to save the current pointer and index the stack, for reasons evident from the above.
+;
+; Note also the probable convenience of being able to index the stack pointer.
+;
+; I want to use DE for the locals stack pointer with HL as the parameter stack pointer,
+; but that makes it unavailable as your first temporary,
+; and temporaries are precisely what the local stack is for.
+;
+; Re-writing to use DE as the parameter stack pointer might be a worthwhile exercise?
+; ****
+
+
+; ORG 0100H ; 8080?
+ NOP
+COLD: JMP COLDENT
+ NOP
+WARM: JMP WARMENT
+
+
+; _LOWORD_ Subtract byte in B from cell pointed to by X:
+; Not really all that useful when you can CLRA and SUBCELL?
+; SUBBYT
+; LDAA 1,X
+; SBA
+; STAA 1,X
+; BCC ADDBYTX
+; DEC 0,X
+; SUBBYTX RTS
+
+; _LOWORD_ Add byte in B to cell pointed to by X:
+; Not really all that useful when you can CLRA and ADDCELL?
+; ADDBYT
+; ADDB 1,X
+; STAB 1,X
+; BCC ADDBYTX
+; INC 0,X
+; ADDBYTX RTS
+
+
+; GETAB MACRO
+; LDX PSP
+; LDAB 1,X
+; LDAA 0,X
+; INX
+; INX
+; STX PSP
+; ENDM
+; Or doing as subroutine would would add 4 bytes and about ten cycles?
+; How useful would it be?
+
+
+;LOGOP: MACRO OP0 ; hides a lot of cycles and object code
+; MOV A,M
+; INX H
+; INX H
+; OP0 M ; less significant byte on 8080
+; MOV M,A
+; DCX H
+; MOV A,M
+; INX H
+; INX H
+; OP0 M ; more significant byte on 8080
+; DCX H
+; RET
+; ENDM
+
+
+; _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
+AND: MOV A,M
+ INX H
+ INX H
+ ANA M ; less significant byte on 8080
+ MOV M,A
+ DCX H
+ MOV A,M
+ INX H
+ INX H
+ ANA M ; more significant byte on 8080
+ DCX H
+ RET
+
+; _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
+OR: MOV A,M
+ INX H
+ INX H
+ ORA M ; less significant byte on 8080
+ MOV M,A
+ DCX H
+ MOV A,M
+ INX H
+ INX H
+ ORA M ; more significant byte on 8080
+ DCX H
+ RET
+
+; _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
+XOR: MOV A,M
+ INX H
+ INX H
+ XRA M ; less significant byte on 8080
+ MOV M,A
+ DCX H
+ MOV A,M
+ INX H
+ INX H
+ XRA M ; more significant byte on 8080
+ DCX H
+ RET
+
+
+; _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
+ADD: MOV A,M
+ INX H
+ INX H
+ ADD M ; less significant byte on 8080
+ MOV M,A
+ DCX H
+ MOV A,M
+ INX H
+ INX H
+ ADC M ; more significant byte on 8080
+ DCX H
+ RET
+;
+; STC ; clear carry (LSB first required!)
+; CMC ; So we don't have to rewrite all of LOGOP
+; LOGOP ADC ; to use ADD first and ADC second.
+
+; _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
+SUB: MOV A,M
+ INX H
+ INX H
+ SUB M ; less significant byte on 8080
+ MOV M,A
+ DCX H
+ MOV A,M
+ INX H
+ INX H
+ SBB M ; more significant byte on 8080
+ DCX H
+ RET
+;
+; STC ; clear carry (See ADD.)
+; CMC
+; LOGOP SBB
+
+
+; _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
+; (Refer to Forth's C@, but byte is not character!)
+BFETCH: MOV C,M
+ INX H
+ MOV B,M
+ LDAX B ; fetch it
+ MVI C,0
+ MOV M,C ; Clear high byte.
+ DCX H
+ MOV M,A ; Store byte
+ RET ; PSP unchanged
+
+; _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+; (Refer to Forth's C!, but byte is not character!)
+BSTORE: MOV C,M ; address low byte
+ INX H
+ MOV B,M ; address high byte
+ INX H
+ MOV A,M ; ignore high byte.
+ STAX B
+ INX H
+ INX H
+ RET
+
+; ASSERT CELLSZ == ADRWDSZ
+; _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
+FETCH: MOV C,M
+ INX H
+ MOV B,M
+ INX B
+ LDAX B ; Fetch high byte
+ MOV M,A ; Store it.
+ DCX B
+ DCX H
+ LDAX B ; Fetch low byte
+ MOV M,A ; Store it.
+ RET ; PSP unchanged
+
+; _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
+STORE: MOV C,M ; address low byte
+ INX H
+ MOV B,M ; address high byte
+ INX H
+ MOV A,M ; data low byte
+ STAX B
+ INX H
+ MOV A,M ; data high byte
+ INX B
+ STAX B
+ INX H
+ RET
+
+
+; _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- uproduct(n1*n2) ):
+USTAR: MOV E,M ; multiplier
+ INX H
+ MOV D,M
+ MVI M,CELLBSZ ; Reuse for count
+ MVI C,0 ; Clear sum.
+ MOV B,C
+ STC
+ CMC
+USTAL: MOV A,D ; multiplier
+ RAR ; carry to high bit, bit 8 to carry
+ MOV D,A
+ MOV A,C
+ RAR ; carry to bit 7, low (multiplying) bit to carry
+ DCR M ; count
+ JM USTAX
+ JNC USTAN ; carry is from RAR
+ INX H ; point back to multiplicand
+ MOV A,C
+ ADD M ; less significant byte
+ MOV C,A
+ INX H
+ MOV A,B
+ ADC M ; more significant byte
+ MOV B,A
+ DCX H ; back to count
+USTAN: MOV A,B
+ RAR ; carry from add to high bit
+ MOV B,A
+ MOV A,C
+ RAR ; rest of sum down the columns
+ MOV C,A ; carry will move into unused multiplicand high bit.
+ JMP USTAL
+USTAX: INX H ; multiplicand
+ INX H ; highest byte
+ MOV M,B
+ DCX H
+ MOV M,C
+ DCX H
+ MOV M,E ; low word high byte
+ DCX H
+ MOV M,D ; lowest byte
+ RET
+ MOV M,C ; Store high word of result over count
+ DCX H
+ MOV M,B ;
+ RET
+
+; _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
+SWAP: MOV C,M
+ INX H
+ MOV B,M
+ INX H
+ MOV E,M
+ INX H
+ MOV D,M
+ MOV M,B
+ DCX H
+ MOV M,C
+ DCX H
+ MOV M,E
+ DCX H
+ MOV M,D
+ RET
+
+; _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
+; ( ud u --- uremainder uquotient )
+; Dividend should be range of product of 16 by 16 bit unsigned multiply,
+; divisor should be the multiplier or multiplicand in such multiply:
+; Needs to be checked when I've had a bit more rest and can load an emulator/debugger and assembler.
+USLASH: INX H ; leave the divisor on the stack
+ INX H
+ MOV E,M ; dividend low word low byte
+ INX H
+ MOV D,M
+ INX H
+ MOV C,M
+ INX H
+ MOV B,M ; dividend high word high byte
+ DCX H ; registers too full for LXI and DAD
+ DCX H
+ DCX H ; empty (dividend)
+ DCX H
+ DCX H ; divisor low byte
+ DCX H ; allocate count
+ MVI M,CELLBSZ+1 ; one more than bits/cell
+ INX H ; back to divisor low byte
+USLLP: MOV A,C ; dividend high word, low byte
+ SUB M ; divisor low byte, compare first
+ INX H ; divisor high byte
+ MOV A,B ; keep only the carry
+ SBB M ; complete compare
+ DCX H ; back to divisor low byte
+ JNC USLSB
+USLNS: CMC ; carry was set, clear it
+ JMP USLNX ; divisor is larger than this rank
+USLSB: MOV B,A ; finish the subtraction, high byte
+ MOV A,C ; redo low byte
+ SUB M
+ MOV C,A ; and record it
+ STC ; for shifting
+USLNX: MOV A,E ; dividend low byte, doubles as result low
+ RAL
+ MOV E,A
+ MOV A,D ; dividend low word high byte, doubles as result high
+ RAL
+ MOV D,A
+ DCX H ; count
+ DCR M
+ INX H
+ JZ USLX
+ MOV A,C
+ RAL
+ MOV C,A
+ MOV A,B
+ RAL
+ MOV B,A
+ JNC USLLP
+ JMP USLSB
+USLX: INX H ; drop divisor
+ INX H
+ INX H ; past most of dividend
+ INX H
+ INX H
+ MOV M,E ; remainder low byte
+ DCX H
+ MOV M,D ; remainder high byte
+ DCX H
+ MOV M,C ; quotient low byte
+ DCX H
+ MOV M,B ; quotient high byte
+ RET
+
+; _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
+TOL: MOV C,M ; low byte first
+ INX H
+ MOV B,M
+ INX H
+ PUSH H ; save PSP for a moment because we need LSP
+ LHLD LSP
+ DCX H
+ MOV M,B ; high byte, then low byte
+ DCX H
+ MOV M,C
+ SHLD LSP
+ POP H ; bring PSP back
+ RET
+
+; _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
+TOR: MOV C,M
+ INX H
+ MOV B,M
+ INX H
+ POP D
+ PUSH B
+ PUSH D
+ RET ; Too bad HL is busy being the parameter stack.
+; Note that using either PCHL or XTHL
+; would require making DE the parameter stack.
+
+; _WORD_ Pop top of locals stack to parameter stack ( --- n ) { n --- }:
+LFROM: L> PUSH H ; save PSP for a moment because we need LSP
+ LHLD LSP
+ MOV C,M ; low byte first
+ INX H
+ MOV B,M
+ INX H
+ SHLD LSP
+ POP H ; restore PSP
+ DCX H
+ MOV M,B ; high byte, then low
+ DCX H
+ MOV M,C
+ RET
+
+; _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
+RFROM: POP B
+ POP D
+ DCX H
+ MOV M,D
+ DCX H
+ MOV M,E
+ PUSH B
+ RET ; Too bad HL is busy being the parameter stack.
+
+; _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
+L: PUSH H ; save PSP for a moment because we need LSP
+ LHLD LSP
+ MOV C,M ; low byte first
+ INX H
+ MOV B,M ; But do NOT update!
+ POP H ; restore PSP (Good code robbing point?)
+ DCX H
+ MOV M,B ; high byte, then low
+ DCX H
+ MOV M,C
+ RET
+
+; _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
+R: POP B
+ POP D
+ PUSH D
+ PUSH B
+ DCX H
+ MOV M,D
+ DCX H
+ MOV M,E
+
+; _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
+DUP: MOV C,M ; Low byte first
+ INX H
+ MOV B,M
+ DCX H
+ DCX H ; room for duplicate high (Could steal below from LFROM?)
+ MOV M,B
+ DCX H
+ MOV M,C ; low
+ RET
+ RET
+
+; _WORD_ DROP Remove a cell from the parameter stack ( n --- )
+DROP: INX H
+ INX H
+ RET
+
+; _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
+DDROP: INX H
+ INX H
+ INX H
+ INX H
+ RET
+;
+; Probably takes more bytes and cycles?
+; LXI B,4
+; DAD B
+; RTS
+; Or
+; CALL DROP
+; JMP DROP
+; Etc.
+
+; Should true be set as 1 or -1?
+; Going with all bits False (0)
+; or all bits True (-1) as the flag to set.
+; _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
+ZEQU: MOV A,M
+ INX H
+ ORA M
+ JNZ ZEQUF
+ CMA ; 0 => -1
+ JMP ZEQUD
+ZEQUF: XRA A
+ZEQUD: MOV M,A ; High byte
+ DCX H
+ MOV M,A ; Low byte
+ RET
+;
+; True as 1 would look like
+; ZEQU: MVI C,0
+; MOV A,M
+; INX H
+; ORA M
+; JNZ ZEQUF
+; INR A ; 0 => 1
+; JMP ZEQUD
+; ZEQUF: XRA A
+; ZEQUD: MOV M,C ; High byte
+; DCX H
+; MOV M,A ; Low byte
+; RET
+
+; _LOWORD_ Move 256 bytes or less going up:
+; 0=256, do not enter without pretesting for 0 count!
+; source in IXSRC, destination in IXDEST, count in B:
+; Overlaps only work if source is higher than dest.
+SMOVEUP:
+ BSR GMVPRM
+SMOVEUL:
+ LDX IXSRC
+ LDAA 0,X
+ INX
+ STX IXSRC
+ LDX IXDEST
+ STAA 0,X
+ INX
+ STX IXDEST
+ DECB
+ BNE SMOVEUL
+ RTS
+
+; _LOWORD_ Move 256 bytes or less going down:
+; 0=256, do not enter without pretesting for 0 count!
+; source in IXSRC, destination in IXDEST, count in B, A is overwritten:
+; Overlaps only work if source is higher than dest.
+SMOVEDN:
+ BSR GMVPRM
+SMOVEDL:
+ TBA
+ ADDA IXSRC+1
+ STAA IXSRC+1
+ CLRA ; 1# 2~ -- BCC takes 2#, 4~; INC IXSRC takes 3# & 6~
+ ADCA IXSRC ; 2# 3~
+ STAA IXSRC ; 2# 4~
+ TBA
+ ADDA IXDEST+1
+ STAA IXDEST+1
+ CLRA ; 1# 2~ -- BCC takes 2#, 4~; INC IXDEST takes 3# & 6~
+ ADCA IXDEST ; 2# 3~
+ STAA IXDEST ; 2# 4~
+SMOVEDL:
+ LDX IXSRC
+ DEX
+ LDAA 0,X
+ STX IXSRC
+ LDX IXDEST
+ DEX
+ STAA 0,X
+ STX IXDEST
+ DECB
+ BNE SMOVEDL
+ RTS
+
+; _LOWORD_ Set up parameters for MOVE ( src dest count --- )
+; Return without copying if count is zero or if 2^15 or more.
+; Make sure destination is left in A:B for math.
+GMVPRM:
+ LDX PSP ; get paramaters for move
+ LDX 0,X ; count
+ BEQ GMVPRX ; bail now if zero
+ BMI GMVPRX ; also if greater than 32K
+ STX GCOUNT
+ LDX PSP
+ LDAA CELLSZ,X ; preparing for math
+ LDAB CELLSZ+1,X
+ STAA IXDEST
+ STAB IXDEST+1
+ LDX CELLSZ+ADRWDSZ,X
+ STX IXDEST
+ RTS ; Back to MOVE that called us.
+;
+GMVPRX:
+ INS ; Drop return to MOVE code.
+ INS
+ BRA DEALL3
+
+; _WORD_ Move up to 32K bytes ( src dest count --- ):
+; Copies zero when count >= 2^15
+; Compare CMOVE in Forth.
+BMOVE:
+ BSR GMVPRM
+ SUBB CELLSZ+ADRWDSZ+1,X ;
+ SBCA CELLSZ+ADRWDSZ,X
+ STAB TEMP+1
+ STAA TEMP
+ BCS BMOVEDN
+BMOVEUP:
+;***** Working in here to make it go both ways.
+;***** Also need to check multiply and divide.
+
+ LDX PSP
+ LDX CELLSZ+ADRWDSZ,X
+ STX IXSRC
+;
+ SUBB
+
+
+ LDAB GCOUNT+1 ; Get low byte for partial block
+ CLR GCOUNT+1 ; To avoid debugging confusion.
+BMOVEL: BSR SMOVE ; partial block and full blocks
+ DEC GCOUNT ; count high byte down (blocks)
+ BPL BMOVEL ; This limits the count.
+; Rob point to deallocate 3 on stack, as long as CELLSZ == ADRWDSZ.
+DEALL3:
+ LDAB PSP+1 ; 2# 3~
+ ADDB #(CELLSZ+2*ADRWDSZ) ; 2# 3~
+ STAB PSP+1 ; 2# 4~
+ BCC BMOVEX ; 2# 4~
+ INC PSP ; 3# 6~ Unaries have no direct page version. => 11# 20~
+BMOVEX: RTS
+; DEALL3
+; LDAB PSP+1 ; 2# 3~
+; ADDB #(CELLSZ+2*ADRWDSZ) ; 2# 3~
+; STAB PSP+1 ; 2# 4~
+; LDAA PSP ; 2# 3~
+; ADCA #(CELLSZ+2*ADRWDSZ) ; 2# 3~
+; STAA PSP ; 2# 4~ => 12# 20~
+; RTS
+; DEALL3
+; LDX PSP ; 6 INXs is around the breakover point in the 6800.
+; INX ; 2 + 6 + 2 bytes => 11#
+; INX ; 4 + 24 + 5 cycles => 33~
+; INX
+; INX
+; INX
+; INX
+; STX PSP
+; RTS
+;
+
+
+; _WORD_ Execute the address on the stack:
+EXEC:
+ LDX PSP
+ INX
+ INX
+ STX PSP
+ LDX 0,X
+ JSR 0,X ; For debugging and flattening, no early optimizations.
+ RTS
+
+
+
+COLDENT: LXI SP,RSTKINI
+ LXI H,LSTKINI
+ SHLD LSP
+ LXI H,UPGINI
+ SHLD UP
+ LXI H,SSTKINI ; PSP
+
+WARMENT: EQU COLDENT
+
+
+
OSDN Git Service
