forth: bring ." and ABORT" down to core.fs level

emul/Makefile

@@ -7,7 +7,7 @@ AVRABIN = zasm/avra
 SHELLAPPS = zasm ed
 SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
 # Those Forth source files are in a particular order
-FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs high.fs z80a.fs dummy.fs
+FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs z80a.fs dummy.fs
 FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%}
 CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
 OBJS = emul.o libz80/libz80.o

forth/core.fs

@@ -1,20 +1,26 @@
-: H HERE @ ;
+: H@ HERE @ ;
 : -^ SWAP - ;
 : [LITN] LITN ; IMMEDIATE
 : LIT ROUTINE S [LITN] , ;
 : LITS LIT SCPY ;
 : LIT< WORD LITS ; IMMEDIATE
+: _err LIT< word-not-found (print) ABORT ;
+: ' WORD (find) SKIP? _err ;
+: ['] WORD (find) SKIP? _err LITN ; IMMEDIATE
 : COMPILE ' LITN ['] , , ; IMMEDIATE
 : [COMPILE] ' , ; IMMEDIATE
-: BEGIN H ; IMMEDIATE
+: BEGIN H@ ; IMMEDIATE
-: AGAIN COMPILE (bbr) H -^ C, ; IMMEDIATE
+: AGAIN COMPILE (bbr) H@ -^ C, ; IMMEDIATE
-: UNTIL COMPILE SKIP? COMPILE (bbr) H -^ C, ; IMMEDIATE
+: UNTIL COMPILE SKIP? COMPILE (bbr) H@ -^ C, ; IMMEDIATE
 : ( BEGIN LIT< ) WORD SCMP NOT UNTIL ; IMMEDIATE
 ( Hello, hello, krkrkrkr... do you hear me?
   Ah, voice at last! Some lines above need comments
   BTW: Forth lines limited to 64 cols because of default
   input buffer size in Collapse OS
 
+  "_": words starting with "_" are meant to be "private",
+  that is, only used by their immediate surrondings.
+
   COMPILE: Tough one. Get addr of caller word (example above
   (bbr)) and then call LITN on it. )
 
@@ -24,21 +30,21 @@
 : IF                ( -- a | a: br cell addr )
     COMPILE SKIP?   ( if true, don't branch )
     COMPILE (fbr)
-    H               ( push a )
+    H@              ( push a )
     1 ALLOT         ( br cell allot )
 ; IMMEDIATE
 
 : THEN              ( a -- | a: br cell addr )
-    DUP H -^ SWAP   ( a-H a )
+    DUP H@ -^ SWAP   ( a-H a )
     C!
 ; IMMEDIATE
 
 : ELSE              ( a1 -- a2 | a1: IF cell a2: ELSE cell )
     COMPILE (fbr)
     1 ALLOT
-    DUP H -^ SWAP   ( a-H a )
+    DUP H@ -^ SWAP  ( a-H a )
     C!
-    H 1 -           ( push a. -1 for allot offset )
+    H@ 1 -          ( push a. -1 for allot offset )
 ; IMMEDIATE
 
 : CREATE
@@ -47,18 +53,18 @@
     ,                ( write it )
 ;
 : VARIABLE CREATE 2 ALLOT ;
-: CONSTANT CREATE H ! DOES> @ ;
+: CONSTANT CREATE H@ ! DOES> @ ;
 : = CMP NOT ;
 : < CMP 0 1 - = ;
 : > CMP 1 = ;
 : / /MOD SWAP DROP ;
 : MOD /MOD DROP ;
 
-( In addition to pushing H this compiles 2 >R so that loop
+( In addition to pushing H@ this compiles 2 >R so that loop
   variables are sent to PS at runtime )
 : DO
     COMPILE SWAP COMPILE >R COMPILE >R
-    H
+    H@
 ; IMMEDIATE
 
 ( One could think that we should have a sub word to avoid all
@@ -67,7 +73,7 @@
 : LOOP
     COMPILE R> 1 LITN COMPILE + COMPILE DUP COMPILE >R
     COMPILE I' COMPILE = COMPILE SKIP? COMPILE (bbr)
-    H -^ C,
+    H@ -^ C,
     COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
 ; IMMEDIATE
 
@@ -84,3 +90,16 @@
     SYSVNXT @ ,
     2 SYSVNXT +!
 ;
+
+: ."
+    LIT
+    BEGIN
+        C< DUP          ( c c )
+        ( 34 is ASCII for " )
+        DUP 34 = IF DROP DROP 0 0 THEN
+        C,
+    0 = UNTIL
+    COMPILE (print)
+; IMMEDIATE
+
+: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE

forth/dictionary.txt

@@ -124,7 +124,7 @@ C@          a -- c          Set c to byte at address a
 C!          c a --          Store byte c in address a
 CURRENT     -- a            Set a to wordref of last added entry.
 HERE        -- a            Push HERE's address
-H           -- a            HERE @
+H@          -- a            HERE @
 
 *** Arithmetic / Bits ***
 

forth/dummy.fs

@@ -7,5 +7,5 @@
   current HERE value. The staging executable needs it to know
   what to dump. )
 
-HERE @ 256 / 2 PC!
+H@ 256 / 2 PC!
-HERE @ 2 PC!
+H@ 2 PC!

forth/forth.asm

@@ -21,11 +21,6 @@
 ;
 ; PutC: Write character specified in A onto the device.
 ;
-; *** ASCII ***
-.equ	BS	0x08
-.equ	CR	0x0d
-.equ	LF	0x0a
-.equ	DEL	0x7f
 ; *** Const ***
 ; Base of the Return Stack
 .equ	RS_ADDR		0xf000
@@ -139,7 +134,7 @@ forthMain:
 	call	find
 	ld	(PARSEPTR), de
 	; Set up CINPTR
-	; do we have a C< impl?
+	; do we have a (c<) impl?
 	ld	hl, .cinName
 	call	find
 	jr	z, .skip
@@ -155,7 +150,7 @@ forthMain:
 	jp	EXECUTE+2
 
 .cinName:
-	.db	"C<", 0
+	.db	"(c<)", 0
 
 BEGIN:
 	.dw	compiledWord
@@ -738,36 +733,9 @@ PRINT:
 	inc	hl
 	jr	.loop
 
-; ( c port -- )
-	.db "PC!"
-	.fill 4
-	.dw $-PRINT
-	.db 0
-PSTORE:
-	.dw nativeWord
-	pop	bc
-	pop	hl
-	call	chkPS
-	out	(c), l
-	jp	next
-
-; ( port -- c )
-	.db "PC@"
-	.fill 4
-	.dw $-PSTORE
-	.db 0
-PFETCH:
-	.dw nativeWord
-	pop	bc
-	call	chkPS
-	ld	h, 0
-	in	l, (c)
-	push	hl
-	jp	next
-
 	.db	"C,"
 	.fill	5
-	.dw	$-PFETCH
+	.dw	$-PRINT
 	.db	0
 CWR:
 	.dw	nativeWord
@@ -1023,43 +991,10 @@ FIND_:
 	push	de
 	jp	next
 
-	.db	"'"
-	.fill	6
-	.dw	$-FIND_
-	.db	0
-FIND:
-	.dw	compiledWord
-	.dw	WORD
-	.dw	FIND_
-	.dw	CSKIP
-	.dw	FINDERR
-	.dw	EXIT
-
-	.db	"[']"
-	.fill	4
-	.dw	$-FIND
-	.db	0b01		; IMMEDIATE
-FINDI:
-	.dw	compiledWord
-	.dw	WORD
-	.dw	FIND_
-	.dw	CSKIP
-	.dw	FINDERR
-	.dw	LITN
-	.dw	EXIT
-
-FINDERR:
-	.dw	compiledWord
-	.dw	DROP		; Drop str addr, we don't use it
-	.dw	LIT
-	.db	"word not found", 0
-	.dw	PRINT
-	.dw	ABORT
-
 ; ( -- c )
 	.db "KEY"
 	.fill 4
-	.dw $-FINDI
+	.dw $-FIND_
 	.db 0
 KEY:
 	.dw nativeWord
@@ -1070,8 +1005,11 @@ KEY:
 	jp	next
 
 ; This is an indirect word that can be redirected through "CINPTR"
-; This is not a real word because it's not meant to be referred to in Forth
 ; code: it is replaced in readln.fs.
+	.db "C<"
+	.fill 5
+	.dw $-KEY
+	.db 0
 CIN:
 	.dw	compiledWord
 	.dw	NUMBER
@@ -1088,7 +1026,7 @@ CIN:
 ; 32 CMP 1 -
 	.db	"WS?"
 	.fill	4
-	.dw	$-KEY
+	.dw	$-CIN
 	.db	0
 ISWS:
 	.dw	compiledWord
@@ -1320,23 +1258,10 @@ STORE:
 	ld	(iy+1), h
 	jp	next
 
-; ( n a -- )
-	.db "C!"
-	.fill 5
-	.dw $-STORE
-	.db 0
-CSTORE:
-	.dw nativeWord
-	pop	hl
-	pop	de
-	call	chkPS
-	ld	(hl), e
-	jp	next
-
 ; ( a -- n )
 	.db "@"
 	.fill 6
-	.dw $-CSTORE
+	.dw $-STORE
 	.db 0
 FETCH:
 	.dw nativeWord
@@ -1346,24 +1271,10 @@ FETCH:
 	push	hl
 	jp	next
 
-; ( a -- c )
-	.db "C@"
-	.fill 5
-	.dw $-FETCH
-	.db 0
-CFETCH:
-	.dw nativeWord
-	pop	hl
-	call	chkPS
-	ld	l, (hl)
-	ld	h, 0
-	push	hl
-	jp	next
-
 ; ( a -- )
 	.db "DROP"
 	.fill 3
-	.dw $-CFETCH
+	.dw $-FETCH
 	.db 0
 DROP:
 	.dw nativeWord
@@ -1537,49 +1448,13 @@ DIVMOD:
 	jp	next
 
 
-	.db	"OR"
-	.fill	5
-	.dw	$-DIVMOD
-	.db	0
-OR:
-	.dw	nativeWord
-	pop	hl
-	pop	de
-	call	chkPS
-	ld	a, e
-	or	l
-	ld	l, a
-	ld	a, d
-	or	h
-	ld	h, a
-	push	hl
-	jp	next
-
-	.db	"XOR"
-	.fill	4
-	.dw	$-OR
-	.db	0
-XOR:
-	.dw	nativeWord
-	pop	hl
-	pop	de
-	call	chkPS
-	ld	a, e
-	xor	l
-	ld	l, a
-	ld	a, d
-	xor	h
-	ld	h, a
-	push	hl
-	jp	next
-
 ; It might look peculiar to have specific words for "0" and "1", but although
 ; it slightly beefs ups the ASM part of the binary, this one-byte-save-per-use
 ; really adds up when we compare total size.
 
 	.db	"0"
 	.fill	6
-	.dw	$-XOR
+	.dw	$-DIVMOD
 	.db	0
 ZERO:
 	.dw	nativeWord

forth/high.fs

@@ -1,14 +0,0 @@
-( Higher level stuff that generally requires all core units )
-
-: ."
-    LIT
-    BEGIN
-        C< DUP          ( c c )
-        ( 34 is ASCII for " )
-        DUP 34 = IF DROP DROP 0 0 THEN
-        C,
-    0 = UNTIL
-    COMPILE (print)
-; IMMEDIATE
-
-: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE

forth/readln.fs

@@ -21,9 +21,9 @@
 
 ( Initializes the readln subsystem )
 : (c<$)
-    HERE @ IN( !
+    H@ IN( !
     INBUFSZ ALLOT
-    HERE @ IN) !
+    H@ IN) !
     (infl)
 ;
 
@@ -69,8 +69,8 @@
     IN( @ IN> !
 ;
 
-( And finally, implement a replacement for the C< routine )
+( And finally, implement a replacement for the (c<) routine )
-: C<
+: (c<)
     IN> @ C@                    ( c )
     ( not EOL? good, inc and return )
     DUP IF 1 IN> +! EXIT THEN   ( c )

forth/z80a.fs

@@ -43,7 +43,6 @@
 ;
 0x04 OP1r INCr,
 0x46 OP1r LDr(HL),
-0x70 OP1r LD(HL)r,
 
 ( r -- )
 : OP1r0
@@ -52,7 +51,10 @@
     C@              ( r op )
     OR A,
 ;
+0x70 OP1r0 LD(HL)r,
 0xa0 OP1r0 ANDr,
+0xb0 OP1r0 ORr,
+0xa8 OP1r0 XORr,
 
 ( qq -- also works for ss )
 : OP1qq
@@ -107,12 +109,25 @@
     C@              ( b r op )
     ROT             ( r op b )
     8 *             ( r op b<<3 )
-    OR OR Z,
+    OR OR A,
 ;
 0xc0 OP2br SETbr,
 0x80 OP2br RESbr,
 0x40 OP2br BITbr,
 
+( cell contains both bytes. MSB is spit as-is, LSB is ORed with r )
+( r -- )
+: OP2r
+    CREATE ,
+    DOES>
+    @ 256 /MOD      ( r lsb msb )
+    A,              ( r lsb )
+    SWAP 8 *        ( lsb r<<3 )
+    OR A,
+;
+0xed41 OP2r OUT(C)r,
+0xed40 OP2r INr(C),
+
 ( dd nn -- )
 : OP3ddnn
     CREATE C,

forth/z80c.fs

@@ -83,3 +83,59 @@ CODE AND
     H A LDrr,
     HL PUSHqq,
 ;CODE
+
+CODE OR
+    HL POPqq,
+    DE POPqq,
+    chkPS,
+    A E LDrr,
+    L ORr,
+    L A LDrr,
+    A D LDrr,
+    H ORr,
+    H A LDrr,
+    HL PUSHqq,
+;CODE
+
+CODE XOR
+    HL POPqq,
+    DE POPqq,
+    chkPS,
+    A E LDrr,
+    L XORr,
+    L A LDrr,
+    A D LDrr,
+    H XORr,
+    H A LDrr,
+    HL PUSHqq,
+;CODE
+
+CODE C!
+    HL POPqq,
+    DE POPqq,
+    chkPS,
+    E LD(HL)r,
+;CODE
+
+CODE C@
+    HL POPqq,
+    chkPS,
+    L LDr(HL),
+    H 0 LDrn,
+    HL PUSHqq,
+;CODE
+
+CODE PC!
+    BC POPqq,
+    HL POPqq,
+    chkPS,
+    L OUT(C)r,
+;CODE
+
+CODE PC@
+    BC POPqq,
+    chkPS,
+    H 0 LDrn,
+    L INr(C),
+    HL PUSHqq,
+;CODE