z80c: Add word "PICK"

blk/046

@@ -9,8 +9,8 @@ SWAP        a b -- b a
 2DUP        a b -- a b a b
 2OVER       a b c d -- a b 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.
 
 
 

forth/boot.fs

@@ -243,7 +243,7 @@ PC ORG @ 0x15 + ! ( popRS )
     RET,
 
 '(' A, 'u' A, 'f' A, 'l' A, 'w' A, ')' A, 0 A,
-L1 BSET ( abortUnderflow )
+L2 BSET ( abortUnderflow )
     HL PC 7 - LDddnn,
     DE RAMSTART 0x02 + LDdd(nn),   ( RAM+02 == CURRENT )
     0x03 CALLnn, ( find )
@@ -262,7 +262,7 @@ PC ORG @ 0x1e + ! ( chkPS )
     SP SUBHLss,
     HL POPqq,
     CNC RETcc,      ( INITIAL_SP >= SP? good )
-    JR, L1 BWR ( abortUnderflow )
+    JR, L2 BWR ( abortUnderflow )
 
 PC ORG @ 0x1b + ! ( next )
 ( 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,
     DE RS_ADDR LDddnn,
     DE SUBHLss,
-    JRC, L1 BWR ( IX < RS_ADDR? abortUnderflow )
+    JRC, L2 BWR ( IX < RS_ADDR? abortUnderflow )
     E 0 IY+ LDrIXY,
     D 1 IY+ LDrIXY,
     IY INCss,

forth/z80c.fs

@@ -62,6 +62,24 @@ CODE OVER
     DE PUSHqq,      ( A )
 ;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 )
 CODE 2DUP
     HL POPqq,       ( B )
@@ -77,6 +95,7 @@ CODE 2DUP
 CODE 2DROP
     HL POPqq,
     HL POPqq,
+    chkPS,
 ;CODE
 
 ( a b c d -- a b c d a b )