forth: Forth-ify "WS?"

I can't get rid of "(fbr)" and "(bbr)" just yet, but soon...

emul/forth/emul.fs

@@ -2,7 +2,7 @@
   stdio port is 0
 )
 
-CODE (emit)
+CODE EMIT
     HL POPqq,
     chkPS,
     A L LDrr,

forth/core.fs

@@ -11,8 +11,8 @@
 : COMPILE ' LITN ['] , , ; IMMEDIATE
 : [COMPILE] ' , ; IMMEDIATE
 : BEGIN H@ ; IMMEDIATE
-: AGAIN COMPILE (bbr) H@ -^ C, ; IMMEDIATE
+: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
-: UNTIL COMPILE SKIP? COMPILE (bbr) H@ -^ C, ; IMMEDIATE
+: UNTIL COMPILE SKIP? COMPILE (br) H@ - , ; IMMEDIATE
 : ( BEGIN LIT< ) WORD SCMP NOT UNTIL ; IMMEDIATE
 ( Hello, hello, krkrkrkr... do you hear me?
   Ah, voice at last! Some lines above need comments
@@ -23,29 +23,29 @@
   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. )
+  (br)) and then call LITN on it. )
 
 : +! SWAP OVER @ + SWAP ! ;
 : ALLOT HERE +! ;
 
 : IF                ( -- a | a: br cell addr )
     COMPILE SKIP?   ( if true, don't branch )
-    COMPILE (fbr)
+    COMPILE (br)
     H@              ( push a )
-    1 ALLOT         ( br cell allot )
+    2 ALLOT         ( br cell allot )
 ; IMMEDIATE
 
 : THEN              ( a -- | a: br cell addr )
     DUP H@ -^ SWAP   ( a-H a )
-    C!
+    !
 ; IMMEDIATE
 
 : ELSE              ( a1 -- a2 | a1: IF cell a2: ELSE cell )
-    COMPILE (fbr)
+    COMPILE (br)
-    1 ALLOT
+    2 ALLOT
     DUP H@ -^ SWAP  ( a-H a )
-    C!
+    !
-    H@ 1 -          ( push a. -1 for allot offset )
+    H@ 2 -          ( push a. -2 for allot offset )
 ; IMMEDIATE
 
 : CREATE
@@ -73,8 +73,8 @@
   the RS )
 : LOOP
     COMPILE R> 1 LITN COMPILE + COMPILE DUP COMPILE >R
-    COMPILE I' COMPILE = COMPILE SKIP? COMPILE (bbr)
+    COMPILE I' COMPILE = COMPILE SKIP? COMPILE (br)
-    H@ -^ C,
+    H@ - ,
     COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
 ; IMMEDIATE
 

forth/forth.asm

@@ -32,17 +32,11 @@
 ; *** Const ***
 ; Base of the Return Stack
 .equ	RS_ADDR		0xf000
-; Number of bytes we keep as a padding between HERE and the scratchpad
-.equ	PADDING		0x20
 ; Buffer where WORD copies its read word to.
 .equ	WORD_BUFSIZE		0x20
 ; Allocated space for sysvars (see comment above SYSVCNT)
 .equ	SYSV_BUFSIZE		0x10
 
-; Flags for the "flag field" of the word structure
-; IMMEDIATE word
-.equ	FLAG_IMMED	7
-
 ; *** Variables ***
 .equ	INITIAL_SP	RAMSTART
 ; wordref of the last entry of the dict.
@@ -64,10 +58,6 @@
 ; interface in Forth, which we plug in during init. If "(c<)" exists in the
 ; dict, CINPTR is set to it. Otherwise, we set KEY
 .equ	CINPTR		@+2
-; Pointer to (emit) word
-.equ	EMITPTR		@+2
-; Pointer to (print) word
-.equ	PRINTPTR	@+2
 .equ	WORDBUF		@+2
 ; Sys Vars are variables with their value living in the system RAM segment. We
 ; need this mechanisms for core Forth source needing variables. Because core
@@ -125,10 +115,13 @@ JUMPTBL:
 	jp	nativeWord
 	jp	next
 	jp	chkPS
+; 24
 NUMBER:
 	.dw	numberWord
 LIT:
 	.dw	litWord
+	.dw	INITIAL_SP
+	.dw	WORDBUF
 
 ; *** Code ***
 forthMain:
@@ -138,7 +131,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
@@ -152,14 +145,6 @@ forthMain:
 	ld	hl, .parseName
 	call	find
 	ld	(PARSEPTR), de
-	; Set up EMITPTR
-	ld	hl, .emitName
-	call	find
-	ld	(EMITPTR), de
-	; Set up PRINTPTR
-	ld	hl, .printName
-	call	find
-	ld	(PRINTPTR), de
 	; Set up CINPTR
 	; do we have a (c<) impl?
 	ld	hl, .cinName
@@ -173,30 +158,19 @@ forthMain:
 	; Set up SYSVNXT
 	ld	hl, SYSVBUF
 	ld	(SYSVNXT), hl
-	ld	hl, BEGIN
+	ld	hl, .bootName
-	push	hl
+	call	find
+	push	de
 	jp	EXECUTE+2
 
 .parseName:
 	.db	"(parse)", 0
 .cinName:
 	.db	"(c<)", 0
-.emitName:
-	.db	"(emit)", 0
-.printName:
-	.db	"(print)", 0
 .keyName:
 	.db	"KEY", 0
-
+.bootName:
-BEGIN:
+	.db	"BOOT", 0
-	.dw	compiledWord
-	.dw	LIT
-	.db	"(c<$)", 0
-	.dw	FIND_
-	.dw	NOT
-	.dw	CSKIP
-	.dw	EXECUTE
-	.dw	INTERPRET
 
 INTERPRET:
 	.dw	compiledWord
@@ -206,8 +180,11 @@ INTERPRET:
 	.dw	DROP
 	.dw	EXECUTE
 
-.fill 13
+.fill 56
 
+; STABLE ABI
+; Offset: 00cd
+.out $
 ; *** Collapse OS lib copy ***
 ; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
 ; Forth and the concept of ASM libs will become obsolete. To facilitate this
@@ -671,61 +648,83 @@ QUIT:
 	ld	ix, RS_ADDR
 	jp	next
 
-	.db "ABORT"
+abortUnderflow:
-	.dw $-QUIT
+	ld	hl, .name
-	.db 5
+	call	find
-ABORT:
+	push	de
-	.dw	compiledWord
+	jp	EXECUTE+2
-	.dw	.private
+.name:
-	.dw	QUIT
+	.db "(uflw)", 0
 
-.private:
+	.db	"(br)"
+	.dw	$-QUIT
+	.db	4
+BR:
 	.dw	nativeWord
-	; Reinitialize PS
+	ld	hl, (IP)
-	ld	sp, (INITIAL_SP)
+	ld	e, (hl)
+	inc	hl
+	ld	d, (hl)
+	dec	hl
+	add	hl, de
+	ld	(IP), hl
 	jp	next
 
-abortUnderflow:
+; Skip the compword where HL is currently pointing. If it's a regular word,
-	ld	hl, .word
+; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
-	push	hl
+; to after null-termination.
-	jp	EXECUTE+2
+	.db	"SKIP?"
-.word:
+	.dw	$-BR
-	.dw	compiledWord
+	.db	5
-	.dw	LIT
+CSKIP:
-	.db	"stack underfl", 0
+	.dw	nativeWord
-	.dw	NUMBER
+	pop	hl
-	.dw	PRINTPTR
+	call	chkPS
-	.dw	FETCH
+	ld	a, h
-	.dw	EXECUTE
+	or	l
-	.dw	ABORT
+	jp	z, next		; False, do nothing.
+	ld	hl, (IP)
+	ld	de, NUMBER
+	call	.HLPointsDE
+	jr	z, .isNum
+	ld	de, BR
+	call	.HLPointsDE
+	jr	z, .isNum
+	ld	de, LIT
+	call	.HLPointsDE
+	jr	nz, .isWord
+	; We have a literal
+	inc	hl \ inc hl
+	call	strskip
+	inc	hl		; byte after word termination
+	jr	.end
+.isNum:
+	; skip by 4
+	inc	hl
+	inc	hl
+	; continue to isWord
+.isWord:
+	; skip by 2
+	inc	hl \ inc hl
+.end:
+	ld	(IP), hl
+	jp	next
 
-	.db "BYE"
+; Sets Z if (HL) == E and (HL+1) == D
-	.dw $-ABORT
+.HLPointsDE:
-	.db 3
+	ld	a, (hl)
-BYE:
+	cp	e
-	.dw nativeWord
+	ret	nz		; no
-	halt
+	inc	hl
+	ld	a, (hl)
+	dec	hl
+	cp	d		; Z has our answer
+	ret
 
-; STABLE ABI
+.fill 45
-; Offset: 02aa
-.out $
-; ( c -- )
-	.db "EMIT"
-	.dw $-BYE
-	.db 4
-EMIT:
-	.dw	compiledWord
-	.dw	NUMBER
-	.dw	EMITPTR
-	.dw	FETCH
-	.dw	EXECUTE
-	.dw	EXIT
-
-
-.fill 71
 
 	.db	","
-	.dw	$-EMIT
+	.dw	$-CSKIP
 	.db	1
 WR:
 	.dw	nativeWord
@@ -781,25 +780,10 @@ DOES:
 	jp	EXIT+2
 
 
-.fill 51
+.fill 82
-
-; ( n -- )
-	.db	"LITN"
-	.dw	$-DOES
-	.db	4
-LITN:
-	.dw nativeWord
-	ld	hl, (HERE)
-	ld	de, NUMBER
-	call	DEinHL
-	pop	de		; number from stack
-	call	chkPS
-	call	DEinHL
-	ld	(HERE), hl
-	jp	next
 
 	.db	"SCPY"
-	.dw	$-LITN
+	.dw	$-DOES
 	.db	4
 SCPY:
 	.dw	nativeWord
@@ -846,27 +830,10 @@ CIN:
 	.dw	EXIT
 
 
-; ( c -- f )
+.fill 24
-; 33 CMP 1 + NOT
-; The NOT is to normalize the negative/positive numbers to 1 or 0.
-; Hadn't we wanted to normalize, we'd have written:
-; 32 CMP 1 -
-	.db	"WS?"
-	.dw	$-CIN
-	.db	3
-ISWS:
-	.dw	compiledWord
-	.dw	NUMBER
-	.dw	33
-	.dw	CMP
-	.dw	NUMBER
-	.dw	1
-	.dw	PLUS
-	.dw	NOT
-	.dw	EXIT
 
 	.db	"NOT"
-	.dw	$-ISWS
+	.dw	$-CIN
 	.db	3
 NOT:
 	.dw	nativeWord
@@ -882,78 +849,11 @@ NOT:
 	push	hl
 	jp	next
 
-; ( -- c )
-; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
-	.db	"TOWORD"
-	.dw	$-NOT
-	.db	6
-TOWORD:
-	.dw	compiledWord
-	.dw	CIN
-	.dw	DUP
-	.dw	ISWS
-	.dw	CSKIP
-	.dw	EXIT
-	.dw	DROP
-	.dw	TOWORD
-	.dw	EXIT
-
-; Read word from C<, copy to WORDBUF, null-terminate, and return, make
-; HL point to WORDBUF.
-	.db "WORD"
-	.dw $-TOWORD
-	.db 4
-; STABLE ABI
-; Offset: 04f7
-.out $
-WORD:
-	.dw	compiledWord
-	.dw	NUMBER		; ( a )
-	.dw	WORDBUF
-	.dw	TOWORD		; ( a c )
-	; branch mark
-	.dw	OVER		; ( a c a )
-	.dw	STORE		; ( a )
-	.dw	NUMBER		; ( a 1 )
-	.dw	1
-	.dw	PLUS		; ( a+1 )
-	.dw	CIN		; ( a c )
-	.dw	DUP		; ( a c c )
-	.dw	ISWS		; ( a c f )
-	.dw	CSKIP		; ( a c )
-	.dw	BBR
-	.db	20	; here - mark
-	; at this point, we have ( a WS )
-	.dw	DROP
-	.dw	NUMBER
-	.dw	0
-	.dw	SWAP		; ( 0 a )
-	.dw	STORE		; ()
-	.dw	NUMBER
-	.dw	WORDBUF
-	.dw	EXIT
-
-.wcpy:
-	.dw	nativeWord
-	ld	de, WORDBUF
-	push	de		; we already have our result
-.loop:
-	ld	a, (hl)
-	cp	' '+1
-	jr	c, .loopend
-	ld	(de), a
-	inc	hl
-	inc	de
-	jr	.loop
-.loopend:
-	; null-terminate the string.
-	xor	a
-	ld	(de), a
-	jp	next
 
+.fill 100
 
 	.db	"(parsed)"
-	.dw	$-WORD
+	.dw	$-NOT
 	.db	8
 PARSED:
 	.dw	nativeWord
@@ -1143,104 +1043,6 @@ CMP:
 	push	bc
 	jp	next
 
-; Skip the compword where HL is currently pointing. If it's a regular word,
+	.db	"_bend"
-; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
-; to after null-termination.
-	.db	"SKIP?"
 	.dw	$-CMP
 	.db	5
-; STABLE ABI
-; Offset: 06ee
-.out $
-CSKIP:
-	.dw	nativeWord
-	pop	hl
-	call	chkPS
-	ld	a, h
-	or	l
-	jp	z, next		; False, do nothing.
-	ld	hl, (IP)
-	ld	de, NUMBER
-	call	.HLPointsDE
-	jr	z, .isNum
-	ld	de, FBR
-	call	.HLPointsDE
-	jr	z, .isBranch
-	ld	de, BBR
-	call	.HLPointsDE
-	jr	z, .isBranch
-	ld	de, LIT
-	call	.HLPointsDE
-	jr	nz, .isWord
-	; We have a literal
-	inc	hl \ inc hl
-	call	strskip
-	inc	hl		; byte after word termination
-	jr	.end
-.isNum:
-	; skip by 4
-	inc	hl
-	; continue to isBranch
-.isBranch:
-	; skip by 3
-	inc	hl
-	; continue to isWord
-.isWord:
-	; skip by 2
-	inc	hl \ inc hl
-.end:
-	ld	(IP), hl
-	jp	next
-
-; Sets Z if (HL) == E and (HL+1) == D
-.HLPointsDE:
-	ld	a, (hl)
-	cp	e
-	ret	nz		; no
-	inc	hl
-	ld	a, (hl)
-	dec	hl
-	cp	d		; Z has our answer
-	ret
-
-; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
-; where to branch to. For example, The branching cell of "IF THEN" would
-; contain 3. Add this value to RS.
-	.db	"(fbr)"
-	.dw	$-CSKIP
-	.db	5
-; STABLE ABI
-; Offset: 073e
-.out $
-FBR:
-	.dw	nativeWord
-	push	de
-	ld	hl, (IP)
-	ld	a, (hl)
-	call	addHL
-	ld	(IP), hl
-	pop	de
-	jp	next
-
-	.db	"(bbr)"
-	.dw	$-FBR
-	.db	5
-; STABLE ABI
-; Offset: 0757
-.out $
-BBR:
-	.dw	nativeWord
-	ld	hl, (IP)
-	ld	d, 0
-	ld	e, (hl)
-	or	a		; clear carry
-	sbc	hl, de
-	ld	(IP), hl
-	jp	next
-
-; To allow dict binaries to "hook themselves up", we always end such binary
-; with a dummy, *empty* entry. Therefore, we can have a predictable place for
-; getting a prev label.
-	.db	"_bend"
-	.dw	$-BBR
-	.db	5

forth/icore.fs

@@ -49,24 +49,12 @@
     ,           ( write! )
 ; IMMEDIATE
 
-: INTERPRET
+: ABORT _c (resSP) QUIT ;
-    BEGIN
-    WORD
-    (find)
-    IF
-        1 FLAGS !
-        EXECUTE
-        0 FLAGS !
-    ELSE
-        (parse*) @ EXECUTE
-    THEN
-    AGAIN
-;
 
 ( This is only the "early parser" in earlier stages. No need
   for an abort message )
 : (parse)
-    (parsed) SKIP? ABORT
+    (parsed) SKIP? _c ABORT
 ;
 
 ( a -- )
@@ -76,19 +64,60 @@
     _c C@       ( a c )
     ( exit if null )
     DUP NOT IF DROP DROP EXIT THEN
-    EMIT        ( a )
+    _c EMIT     ( a )
     1 +         ( a+1 )
     AGAIN
 ;
 
+: (uflw)
+    LIT< stack-underflow _c (print) _c ABORT
+;
+
 : C,
     HERE @ _c C!
     HERE @ 1 + HERE !
 ;
 
+( The NOT is to normalize the negative/positive numbers to 1
+  or 0. Hadn't we wanted to normalize, we'd have written:
+  32 CMP 1 - )
+: WS? 33 CMP 1 + NOT ;
+
+: TOWORD
+    BEGIN
+    C< DUP _c WS? NOT IF EXIT THEN DROP
+    AGAIN
+;
+
+( Read word from C<, copy to WORDBUF, null-terminate, and
+  return, make HL point to WORDBUF. )
+: WORD
+    ( JTBL+30 == WORDBUF )
+    [ JTBL 30 + @ LITN ]        ( a )
+    _c TOWORD                   ( a c )
+    BEGIN
+        ( We take advantage of the fact that char MSB is
+          always zero to pre-write our null-termination )
+        OVER !                  ( a )
+        1 +                     ( a+1 )
+        C<                      ( a c )
+        DUP _c WS?
+    UNTIL
+    ( a this point, PS is: a WS )
+    ( null-termination is already written )
+    DROP DROP
+    [ JTBL 30 + @ LITN ]
+;
+
+: LITN
+    ( JTBL+24 == NUMBER )
+    JTBL 24 + ,
+    ,
+;
+
 : (entry)
     HERE @          ( h )
-    WORD            ( h s )
+    _c WORD         ( h s )
     SCPY            ( h )
     ( Adjust HERE -1 because SCPY copies the null )
     HERE @ 1 _c -   ( h h' )
@@ -101,21 +130,41 @@
     HERE @ CURRENT !
 ;
 
+: INTERPRET
+    BEGIN
+    _c WORD
+    (find)
+    IF
+        1 FLAGS !
+        EXECUTE
+        0 FLAGS !
+    ELSE
+        (parse*) @ EXECUTE
+    THEN
+    AGAIN
+;
+
+: BOOT
+    LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
+    _c INTERPRET
+;
+
 ( : and ; have to be defined last because it can't be
   executed now also, they can't have their real name
   right away )
 
 : X
     _c (entry)
-    ( JTBL+6 == compiledWord )
+    ( We cannot use LITN as IMMEDIATE because of bootstrapping
-    [ JTBL 6 + LITN ] ,
+      issues. JTBL+24 == NUMBER JTBL+6 == compiledWord )
+    [ JTBL 24 + , JTBL 6 + , ] ,
     BEGIN
-    WORD
+    _c WORD
     (find)
     ( is word )
     IF DUP _c IMMED? IF EXECUTE ELSE , THEN
     ( maybe number )
-    ELSE (parse*) @ EXECUTE LITN THEN
+    ELSE (parse*) @ EXECUTE _c LITN THEN
     AGAIN
 ; IMMEDIATE
 

forth/z80a.fs

@@ -2,8 +2,7 @@
 
 ( Splits word into msb/lsb, lsb being on TOS )
 : SPLITB
-    DUP 0x100 /
+    256 /MOD SWAP
-    SWAP 0xff AND
 ;
 
 ( To debug, change C, to .X )
@@ -33,6 +32,9 @@
 : IY+ _iy+- ;
 : IY- 0 -^ _iy+- ;
 
+: <<3 8 * ;
+: <<4 16 * ;
+
 ( -- )
 : OP1 CREATE C, DOES> C@ A, ;
 0x76 OP1 HALT,
@@ -49,7 +51,7 @@
     DOES>
     C@              ( r op )
     SWAP            ( op r )
-    8 *             ( op r<<3 )
+    <<3             ( op r<<3 )
     OR A,
 ;
 0x04 OP1r INCr,
@@ -73,7 +75,7 @@
     DOES>
     C@              ( qq op )
     SWAP            ( op qq )
-    16 *            ( op qq<<4 )
+    <<4             ( op qq<<4 )
     OR A,
 ;
 0xc5 OP1qq PUSHqq,
@@ -85,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,
 ;
 
@@ -126,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,
@@ -138,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,
@@ -166,9 +168,9 @@
 : OP2r
     CREATE ,
     DOES>
-    @ 256 /MOD      ( r lsb msb )
+    @ 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,
@@ -180,7 +182,7 @@
     DOES>
     0xed A,
     C@ SWAP         ( op ss )
-    16 *            ( op ss<< 4 )
+    <<4             ( op ss<< 4 )
     OR A,
 ;
 0x4a OP2ss ADCHLss,
@@ -192,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,
 ;
@@ -223,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, ;
 

forth/z80c.fs

@@ -245,3 +245,12 @@ CODE IMMED?
 ( notset )
     DE PUSHqq,
 ;CODE
+
+CODE BYE
+    HALT,
+;CODE
+
+CODE (resSP)
+    ( INITIAL_SP == JTBL+28 )
+    SP JTBL 28 + @ LDdd(nn),
+;CODE