izaya
/
collapseos
mirror of https://github.com/hsoft/collapseos.git
1
0
Fork 0
Code Issues Releases Wiki Activity

z80c: Add word "PICK"

This commit is contained in:
Virgil Dupras 2020-04-20 21:22:07 -04:00
parent 58c017448f
commit 41ed70f8cb
4 changed files with 24 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
blk/046
View File

@ -9,8 +9,8 @@ SWAP a b -- b a
2DUP a b -- a b a b 2DUP a b -- a b a b
2OVER a b c d -- a b c d a b 2OVER a b c d -- a b c d a b
2SWAP a b c d -- c d a b 2SWAP a b c d -- c d a b
PICK Pick nth item from stack. "0 PICK" = DUP,
"1 PICK" = OVER.

BIN
emul/forth/z80c.bin
View File

Binary file not shown.

6
forth/boot.fs
View File

@ -243,7 +243,7 @@ PC ORG @ 0x15 + ! ( popRS )
RET, RET,
'(' A, 'u' A, 'f' A, 'l' A, 'w' A, ')' A, 0 A, '(' A, 'u' A, 'f' A, 'l' A, 'w' A, ')' A, 0 A,
L1 BSET ( abortUnderflow ) L2 BSET ( abortUnderflow )
HL PC 7 - LDddnn, HL PC 7 - LDddnn,
DE RAMSTART 0x02 + LDdd(nn), ( RAM+02 == CURRENT ) DE RAMSTART 0x02 + LDdd(nn), ( RAM+02 == CURRENT )
0x03 CALLnn, ( find ) 0x03 CALLnn, ( find )
@ -262,7 +262,7 @@ PC ORG @ 0x1e + ! ( chkPS )
SP SUBHLss, SP SUBHLss,
HL POPqq, HL POPqq,
CNC RETcc, ( INITIAL_SP >= SP? good ) CNC RETcc, ( INITIAL_SP >= SP? good )
JR, L1 BWR ( abortUnderflow ) JR, L2 BWR ( abortUnderflow )
PC ORG @ 0x1b + ! ( next ) PC ORG @ 0x1b + ! ( next )
( This routine is jumped to at the end of every word. In it, ( This routine is jumped to at the end of every word. In it,
@ -274,7 +274,7 @@ PC ORG @ 0x1b + ! ( next )
IX PUSHqq, HL POPqq, IX PUSHqq, HL POPqq,
DE RS_ADDR LDddnn, DE RS_ADDR LDddnn,
DE SUBHLss, DE SUBHLss,
JRC, L1 BWR ( IX < RS_ADDR? abortUnderflow ) JRC, L2 BWR ( IX < RS_ADDR? abortUnderflow )
E 0 IY+ LDrIXY, E 0 IY+ LDrIXY,
D 1 IY+ LDrIXY, D 1 IY+ LDrIXY,
IY INCss, IY INCss,

19
forth/z80c.fs
View File

@ -62,6 +62,24 @@ CODE OVER
DE PUSHqq, ( A ) DE PUSHqq, ( A )
;CODE ;CODE
CODE PICK
HL POPqq,
chkPS,
( x2 )
L SLAr,
H RLr,
SP ADDHLss,
C (HL) LDrr,
HL INCss,
B (HL) LDrr,
( check PS range before returning )
EXDEHL,
RAMSTART LDHL(nn), ( RAM+00 == INITIAL_SP )
DE SUBHLss,
CC L2 @ JPccnn, ( abortUnderflow )
BC PUSHqq,
;CODE
( a b -- a b a b ) ( a b -- a b a b )
CODE 2DUP CODE 2DUP
HL POPqq, ( B ) HL POPqq, ( B )
@ -77,6 +95,7 @@ CODE 2DUP
CODE 2DROP CODE 2DROP
HL POPqq, HL POPqq,
HL POPqq, HL POPqq,
chkPS,
;CODE ;CODE
( a b c d -- a b c d a b ) ( a b c d -- a b c d a b )