From 41ed70f8cbefe8ea3b30f1fdd898c54bd77529a3 Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 20 Apr 2020 21:22:07 -0400
Subject: [PATCH] z80c: Add word "PICK"

---
 blk/046             |   4 ++--
 emul/forth/z80c.bin | Bin 2180 -> 2217 bytes
 forth/boot.fs       |   6 +++---
 forth/z80c.fs       |  19 +++++++++++++++++++
 4 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/blk/046 b/blk/046
index a1b5226..efc468f 100644
--- a/blk/046
+++ b/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.
 
 
 
diff --git a/emul/forth/z80c.bin b/emul/forth/z80c.bin
index 323a38283395d7f7f8b95b4eca4d63f826e20ec4..6cd8124ad38134e811e5cc6b6282fa60bf6b2760 100644
GIT binary patch
delta 1016
zcmYjP-%C?r7=FKVzI~gfM=hPAjOHqI!-Ygpt)+P8tdaZS*-ZL{n3@Yh&E|zLSc9<e
zVmEp_k?w*R5{a;@AiFZX3qp|SF0u&n4_ME4j#4+<d7tln-|u;z?|I(vx?%kb>qtaG
zH|vQvf7@}<_POoGE3q>J2R{0~`ODaAVIM!V(uMxv#OdXI)>?xWS;udM4ehN`QgR!L
zP6LB|*OMCAG&ebDm+RCyJ2v-p(&ud;2e4`ryAd|RwZu_#vkna#MmU!8Sv^DlWA$X$
znr(g+iyl6jp77R^(0r)NEP&-h!;w@S7Nz-D?#ijZRS!jCsj!hS!YK;aN-WEC>eJ&!
z$^%OK>Yz=hYYt*s8(#z2p!J#OS>Qd@CY~{i?%)Yhz^{^9!O`gK#Mt<F9j-1iH?`9X
z+Z5E5SOyf_)J<DTk-f6zEHDpHwpG!}QJX}{K&t7pvZ16=S*A>Q<1nSjqN?ooQx^Rv
zv9`d4Nb@DOrIbNG&CBeat;pndr#W3>W%S6oC45<DKP#CWm@lysMy&PTJMd13HDwAm
zKY@%;u+9`!1B3mlw5CggW)*h2RQdact2P&`4s|u5Q6fDiUO2)>lD$q+VM{x;@q%e#
zDn1f7`cJ`{c_E5yQ>-noi?-Y@-w~gfOD*tu6P=<z6{q4R&3xNrC~><3&t^$qH7N=R
z*Qvmh^rNEF-O1_9+`@ei6i6Cn)?}CeMW~h(%kW0lG6`GCqF5DHCCPVU^wQjd_cCS=
zM8K~9i$pzDNeDJKQbtAwCYaGtlQ8#?`<L_f7I4Q!Ft?2N-2mtF;4ByG@p!7;OsxW>
z88ke{PMcXfM3*FVJb}{(Gc%c>*F1HTv|Y|bVi6fm`JP#pBq{tQSPn)~v3pqm*o{mr
zibVn9(P+58w?XEPN3r)AjUu&IHOgyeNk`LrRhkx%uQ+d)?yd?;pA!*GIF7I2XiXx1
RPzc3AN0Rp7@#sZje*pzl*AV~!

delta 1022
zcmYjPO-NK>6usa3^QrlCsxh+7I26v9iAamEDe;X{4d}da-m{@nWc*2H<A}L%(0Bzw
z;3lbM471J6Ahe0u1}!37M+?DiM1+XUZaVjSN^R!NckcbpJ?DIPH}opB_g(12<I~x$
zcTLgL`niXOorkGh`^RfaP4RaWo9<1F-FGe0tq7U4tJxG=Ev!9T>W_!W1lA_82dP}D
zgEX8qc}`B}a;c2hAM{N9k9ARtb)=aph@KW#7ULacSh{YibrA;n)O6bG1W{6}YYkud
zszxcD@lv^LF6B{JuZb;T)0pk#yeK4nQu}n9?wBO36Lk|}6T#mZEf4%|o5US?7)rF0
z0)0)tgwovVVqsyS6Qe64LcKJvFT-6;IFJybA*w1B@m%)<a0Vc^wNmM{jgdN#Hri8m
zlq60;D2s6ip;San<^CI#NB?=y7PUh?scnm@Qipta6L0j2VD@9dw`-z~9=^AYe?je6
z)A6BvThwqRppQRBc8B_=vW%D~U?Z96l%~!hU{mF21}u0!z@ee=?`!QqYao~8Kp2gT
zTvqwFc#7xU(QZ-^OD~-O<On?{@8rfWAeyXiRK!~&7{?-A`rWjN%U9%ETNwMn_$C@k
zQOnBSWjbme!#Y=Na+BFdedr7VDN7~;JT?_Imwtll$<oUDT6s1KUo5LG{uun-Ko$`0
zBd)6S!3$DV3PxF$b)7xM<lXo!-2GyNTkL;}(nYNdA^eNv@FFQ&h?&1GBHzb=EqFP=
z{MdY{w4R6$f+IqMGDQ|!$0F<~5nn<)%XS>ES9(^^bOfg8*_+6%+y}xM0}@#cm}NCW
z{6LJRGihF9etDL_VJtxTMB2;DNcspBjDi6#las0O+0hW5VMB|7_XUkW$8C#VT35+N
q*L#(N9O3uQws7KQBk<gfWxZ~mjnL5QVo?LvmrR#_!1vru5`O`Pqu*@+

diff --git a/forth/boot.fs b/forth/boot.fs
index 672f385..95e8c85 100644
--- a/forth/boot.fs
+++ b/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,
diff --git a/forth/z80c.fs b/forth/z80c.fs
index 4da5d45..e58f4cd 100644
--- a/forth/z80c.fs
+++ b/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 )