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 z80a.fs dummy.fs
+FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs high.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,26 +1,20 @@
-: 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. )
 
@@ -30,21 +24,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
@@ -53,18 +47,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
@@ -73,7 +67,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
 
@@ -90,16 +84,3 @@
     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. )
 
-H@ 256 / 2 PC!
+HERE @ 256 / 2 PC!
-H@ 2 PC!
+HERE @ 2 PC!

forth/forth.asm

@@ -21,6 +21,11 @@
 ;
 ; 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
@@ -134,7 +139,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
@@ -150,7 +155,7 @@ forthMain:
 	jp	EXECUTE+2
 
 .cinName:
-	.db	"(c<)", 0
+	.db	"C<", 0
 
 BEGIN:
 	.dw	compiledWord
@@ -733,9 +738,36 @@ 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	$-PRINT
+	.dw	$-PFETCH
 	.db	0
 CWR:
 	.dw	nativeWord
@@ -991,10 +1023,43 @@ 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 $-FIND_
+	.dw $-FINDI
 	.db 0
 KEY:
 	.dw nativeWord
@@ -1005,11 +1070,8 @@ 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
@@ -1026,7 +1088,7 @@ CIN:
 ; 32 CMP 1 -
 	.db	"WS?"
 	.fill	4
-	.dw	$-CIN
+	.dw	$-KEY
 	.db	0
 ISWS:
 	.dw	compiledWord
@@ -1258,10 +1320,23 @@ 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 $-STORE
+	.dw $-CSTORE
 	.db 0
 FETCH:
 	.dw nativeWord
@@ -1271,10 +1346,24 @@ 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 $-FETCH
+	.dw $-CFETCH
 	.db 0
 DROP:
 	.dw nativeWord
@@ -1448,13 +1537,49 @@ 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	$-DIVMOD
+	.dw	$-XOR
 	.db	0
 ZERO:
 	.dw	nativeWord

forth/high.fs

@@ -0,0 +1,14 @@
+( 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<$)
-    H@ IN( !
+    HERE @ IN( !
     INBUFSZ ALLOT
-    H@ IN) !
+    HERE @ 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,6 +43,7 @@
 ;
 0x04 OP1r INCr,
 0x46 OP1r LDr(HL),
+0x70 OP1r LD(HL)r,
 
 ( r -- )
 : OP1r0
@@ -51,10 +52,7 @@
     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
@@ -109,25 +107,12 @@
     C@              ( b r op )
     ROT             ( r op b )
     8 *             ( r op b<<3 )
-    OR OR A,
+    OR OR Z,
 ;
 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,59 +83,3 @@ 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