From e0eaa8ba631cde53f58f55e80dfa766df3b28fdc Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 28 Mar 2020 10:11:52 -0400
Subject: [PATCH] forth: Forth-ify "ABORT"

---
 emul/forth/z80c.bin | Bin 875 -> 910 bytes
 forth/forth.asm     |  24 ++++++------------------
 forth/icore.fs      |   6 ++++--
 forth/z80a.fs       |  34 ++++++++++++++++++++++++++--------
 forth/z80c.fs       |   5 +++++
 5 files changed, 41 insertions(+), 28 deletions(-)

diff --git a/emul/forth/z80c.bin b/emul/forth/z80c.bin
index 78d02ce68f889439cdfed4a11c4276bd2f833c69..13f40bfb8224c805d0942e0f09b4c5ac7bccf8ef 100644
GIT binary patch
delta 138
zcmaFO*2li#45MUGYH@IYrW6CaIK$g&h8KsW7&KCIGfOo2CtqUJP}wJx%Kes$gV~YE
z(aAq3M3{k<kHM8QfXR``(=Ws|C?Lo+L~t@6laJV9PDdt<g2bZYR83_Dc0L9d)^}|E
qoRbTfyjl3UfQ<c2!NQST7g<%=?z0N8IWk$9Gc@usR8LlAb^`!bz$115

delta 103
zcmeBUf6cbx3?o}=Zf1$5<m9J}8X^TksoZb5IG7!oJpDpkg93tFL&PT=GWm!#a5^$+
z6eJcEr)nxQu=6pvu)br<XPP{j$(!X3Cy?=oDOlKy>msWv+kI96Hb*8abB0DfhKR`?
G%x(Y%P#d)X

diff --git a/forth/forth.asm b/forth/forth.asm
index 1d5d01c..6e5a86d 100644
--- a/forth/forth.asm
+++ b/forth/forth.asm
@@ -117,10 +117,12 @@ JUMPTBL:
 	jp	nativeWord
 	jp	next
 	jp	chkPS
+; 24
 NUMBER:
 	.dw	numberWord
 LIT:
 	.dw	litWord
+	.dw	INITIAL_SP
 
 ; *** Code ***
 forthMain:
@@ -130,7 +132,7 @@ forthMain:
 	; ourselves a nice 6 bytes buffer. 6 bytes because we seldom have words
 	; requiring more than 3 items from the stack. Then, at each "exit" call
 	; we check for stack underflow.
-	push	af \ push af \ push af
+	ld	sp, 0xfffa
 	ld	(INITIAL_SP), sp
 	ld	ix, RS_ADDR
 	; LATEST is a label to the latest entry of the dict. This can be
@@ -185,7 +187,7 @@ INTERPRET:
 	.dw	DROP
 	.dw	EXECUTE
 
-.fill 43
+.fill 41
 
 ; *** Collapse OS lib copy ***
 ; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
@@ -650,20 +652,6 @@ QUIT:
 	ld	ix, RS_ADDR
 	jp	next
 
-	.db "ABORT"
-	.dw $-QUIT
-	.db 5
-ABORT:
-	.dw	compiledWord
-	.dw	.private
-	.dw	QUIT
-
-.private:
-	.dw	nativeWord
-	; Reinitialize PS
-	ld	sp, (INITIAL_SP)
-	jp	next
-
 abortUnderflow:
 	ld	hl, .name
 	call	find
@@ -672,10 +660,10 @@ abortUnderflow:
 .name:
 	.db "(uflw)", 0
 
-.fill 18
+.fill 41
 
 	.db "BYE"
-	.dw $-ABORT
+	.dw $-QUIT
 	.db 3
 BYE:
 	.dw nativeWord
diff --git a/forth/icore.fs b/forth/icore.fs
index 51465ec..8da528c 100644
--- a/forth/icore.fs
+++ b/forth/icore.fs
@@ -49,6 +49,8 @@
     ,           ( write! )
 ; IMMEDIATE
 
+: ABORT _c (resSP) QUIT ;
+
 : INTERPRET
     BEGIN
     WORD
@@ -71,7 +73,7 @@
 ( This is only the "early parser" in earlier stages. No need
   for an abort message )
 : (parse)
-    (parsed) SKIP? ABORT
+    (parsed) SKIP? _c ABORT
 ;
 
 ( a -- )
@@ -87,7 +89,7 @@
 ;
 
 : (uflw)
-    LIT< stack-underflow _c (print) ABORT
+    LIT< stack-underflow _c (print) _c ABORT
 ;
 
 : C,
diff --git a/forth/z80a.fs b/forth/z80a.fs
index ab50dda..9d36c3e 100644
--- a/forth/z80a.fs
+++ b/forth/z80a.fs
@@ -32,6 +32,9 @@
 : IY+ _iy+- ;
 : IY- 0 -^ _iy+- ;
 
+: <<3 8 * ;
+: <<4 16 * ;
+
 ( -- )
 : OP1 CREATE C, DOES> C@ A, ;
 0x76 OP1 HALT,
@@ -48,7 +51,7 @@
     DOES>
     C@              ( r op )
     SWAP            ( op r )
-    8 *             ( op r<<3 )
+    <<3             ( op r<<3 )
     OR A,
 ;
 0x04 OP1r INCr,
@@ -72,7 +75,7 @@
     DOES>
     C@              ( qq op )
     SWAP            ( op qq )
-    16 *            ( op qq<<4 )
+    <<4             ( op qq<<4 )
     OR A,
 ;
 0xc5 OP1qq PUSHqq,
@@ -84,7 +87,7 @@
 : _1rr
     C@              ( rd rr op )
     ROT             ( rr op rd )
-    8 *             ( rr op rd<<3 )
+    <<3             ( rr op rd<<3 )
     OR OR A,
 ;
 
@@ -125,7 +128,7 @@
     DOES>
     C@              ( r n op )
     ROT             ( n op r )
-    8 *             ( n op r<<3 )
+    <<3             ( n op r<<3 )
     OR A, A,
 ;
 0x06 OP2rn LDrn,
@@ -137,7 +140,7 @@
     0xcb A,
     C@              ( b r op )
     ROT             ( r op b )
-    8 *             ( r op b<<3 )
+    <<3             ( r op b<<3 )
     OR OR A,
 ;
 0xc0 OP2br SETbr,
@@ -167,7 +170,7 @@
     DOES>
     @ SPLITB SWAP   ( r lsb msb )
     A,              ( r lsb )
-    SWAP 8 *        ( lsb r<<3 )
+    SWAP <<3        ( lsb r<<3 )
     OR A,
 ;
 0xed41 OP2r OUT(C)r,
@@ -179,7 +182,7 @@
     DOES>
     0xed A,
     C@ SWAP         ( op ss )
-    16 *            ( op ss<< 4 )
+    <<4             ( op ss<< 4 )
     OR A,
 ;
 0x4a OP2ss ADCHLss,
@@ -191,7 +194,7 @@
     DOES>
     C@              ( dd nn op )
     ROT             ( nn op dd )
-    16 *            ( nn op dd<<4 )
+    <<4             ( nn op dd<<4 )
     OR A,
     SPLITB A, A,
 ;
@@ -222,6 +225,21 @@
 0x10 OPJR DJNZe,
 
 ( Specials )
+
+( dd nn -- )
+: LDdd(nn),
+    0xed A,
+    SWAP <<4 0x4b OR A,
+    SPLITB A, A,
+;
+
+( nn dd -- )
+: LD(nn)dd,
+    0xed A,
+    <<4 0x43 OR A,
+    SPLITB A, A,
+;
+
 ( JTBL+18 == next )
 : JPNEXT, [ JTBL 18 + LITN ] JPnn, ;
 
diff --git a/forth/z80c.fs b/forth/z80c.fs
index 4610308..9ed22b2 100644
--- a/forth/z80c.fs
+++ b/forth/z80c.fs
@@ -245,3 +245,8 @@ CODE IMMED?
 ( notset )
     DE PUSHqq,
 ;CODE
+
+CODE (resSP)
+    ( INITIAL_SP == JTBL+28 )
+    SP JTBL 28 + @ LDdd(nn),
+;CODE