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 (br) H@ - , ; IMMEDIATE
+: AGAIN COMPILE (bbr) H@ -^ C, ; IMMEDIATE
-: UNTIL COMPILE SKIP? COMPILE (br) H@ - , ; 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
@@ -23,29 +23,29 @@
   that is, only used by their immediate surrondings.
 
   COMPILE: Tough one. Get addr of caller word (example above
-  (br)) and then call LITN on it. )
+  (bbr)) 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 (br)
+    COMPILE (fbr)
     H@              ( push a )
-    2 ALLOT         ( br cell allot )
+    1 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 (br)
+    COMPILE (fbr)
-    2 ALLOT
+    1 ALLOT
     DUP H@ -^ SWAP  ( a-H a )
-    !
+    C!
-    H@ 2 -          ( push a. -2 for allot offset )
+    H@ 1 -          ( push a. -1 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 (br)
+    COMPILE I' COMPILE = COMPILE SKIP? COMPILE (bbr)
-    H@ - ,
+    H@ -^ C,
     COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
 ; IMMEDIATE
 

forth/forth.asm

@@ -32,11 +32,17 @@
 ; *** 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.
@@ -58,6 +64,10 @@
 ; 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
@@ -115,13 +125,10 @@ JUMPTBL:
 	jp	nativeWord
 	jp	next
 	jp	chkPS
-; 24
 NUMBER:
 	.dw	numberWord
 LIT:
 	.dw	litWord
-	.dw	INITIAL_SP
-	.dw	WORDBUF
 
 ; *** Code ***
 forthMain:
@@ -131,7 +138,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.
-	ld	sp, 0xfffa
+	push	af \ push af \ push af
 	ld	(INITIAL_SP), sp
 	ld	ix, RS_ADDR
 	; LATEST is a label to the latest entry of the dict. This can be
@@ -145,6 +152,14 @@ 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
@@ -158,19 +173,30 @@ forthMain:
 	; Set up SYSVNXT
 	ld	hl, SYSVBUF
 	ld	(SYSVNXT), hl
-	ld	hl, .bootName
+	ld	hl, BEGIN
-	call	find
+	push	hl
-	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:
+
-	.db	"BOOT", 0
+BEGIN:
+	.dw	compiledWord
+	.dw	LIT
+	.db	"(c<$)", 0
+	.dw	FIND_
+	.dw	NOT
+	.dw	CSKIP
+	.dw	EXECUTE
+	.dw	INTERPRET
 
 INTERPRET:
 	.dw	compiledWord
@@ -180,11 +206,8 @@ INTERPRET:
 	.dw	DROP
 	.dw	EXECUTE
 
-.fill 56
+.fill 13
 
-; 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
@@ -648,83 +671,61 @@ QUIT:
 	ld	ix, RS_ADDR
 	jp	next
 
-abortUnderflow:
+	.db "ABORT"
-	ld	hl, .name
-	call	find
-	push	de
-	jp	EXECUTE+2
-.name:
-	.db "(uflw)", 0
-
-	.db	"(br)"
 	.dw $-QUIT
-	.db	4
-BR:
-	.dw	nativeWord
-	ld	hl, (IP)
-	ld	e, (hl)
-	inc	hl
-	ld	d, (hl)
-	dec	hl
-	add	hl, de
-	ld	(IP), hl
-	jp	next
-
-; Skip the compword where HL is currently pointing. If it's a regular word,
-; 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	$-BR
 	.db 5
-CSKIP:
+ABORT:
+	.dw	compiledWord
+	.dw	.private
+	.dw	QUIT
+
+.private:
 	.dw	nativeWord
-	pop	hl
+	; Reinitialize PS
-	call	chkPS
+	ld	sp, (INITIAL_SP)
-	ld	a, h
-	or	l
-	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
 
-; Sets Z if (HL) == E and (HL+1) == D
+abortUnderflow:
-.HLPointsDE:
+	ld	hl, .word
-	ld	a, (hl)
+	push	hl
-	cp	e
+	jp	EXECUTE+2
-	ret	nz		; no
+.word:
-	inc	hl
+	.dw	compiledWord
-	ld	a, (hl)
+	.dw	LIT
-	dec	hl
+	.db	"stack underfl", 0
-	cp	d		; Z has our answer
+	.dw	NUMBER
-	ret
+	.dw	PRINTPTR
+	.dw	FETCH
+	.dw	EXECUTE
+	.dw	ABORT
 
-.fill 45
+	.db "BYE"
+	.dw $-ABORT
+	.db 3
+BYE:
+	.dw nativeWord
+	halt
+
+; STABLE ABI
+; 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	$-CSKIP
+	.dw	$-EMIT
 	.db	1
 WR:
 	.dw	nativeWord
@@ -780,10 +781,25 @@ DOES:
 	jp	EXIT+2
 
 
-.fill 82
+.fill 51
+
+; ( 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	$-DOES
+	.dw	$-LITN
 	.db	4
 SCPY:
 	.dw	nativeWord
@@ -830,10 +846,27 @@ CIN:
 	.dw	EXIT
 
 
-.fill 24
+; ( c -- f )
+; 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	$-CIN
+	.dw	$-ISWS
 	.db	3
 NOT:
 	.dw	nativeWord
@@ -849,11 +882,78 @@ 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	$-NOT
+	.dw	$-WORD
 	.db	8
 PARSED:
 	.dw	nativeWord
@@ -1043,6 +1143,104 @@ CMP:
 	push	bc
 	jp	next
 
-	.db	"_bend"
+; Skip the compword where HL is currently pointing. If it's a regular word,
+; 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,12 +49,24 @@
     ,           ( write! )
 ; IMMEDIATE
 
-: ABORT _c (resSP) QUIT ;
+: INTERPRET
+    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? _c ABORT
+    (parsed) SKIP? ABORT
 ;
 
 ( a -- )
@@ -64,60 +76,19 @@
     _c C@       ( a c )
     ( exit if null )
     DUP NOT IF DROP DROP EXIT THEN
-    _c EMIT     ( a )
+    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 )
-    _c WORD         ( h s )
+    WORD            ( h s )
     SCPY            ( h )
     ( Adjust HERE -1 because SCPY copies the null )
     HERE @ 1 _c -   ( h h' )
@@ -130,41 +101,21 @@
     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)
-    ( We cannot use LITN as IMMEDIATE because of bootstrapping
+    ( JTBL+6 == compiledWord )
-      issues. JTBL+24 == NUMBER JTBL+6 == compiledWord )
+    [ JTBL 6 + LITN ] ,
-    [ JTBL 24 + , JTBL 6 + , ] ,
     BEGIN
-    _c WORD
+    WORD
     (find)
     ( is word )
     IF DUP _c IMMED? IF EXECUTE ELSE , THEN
     ( maybe number )
-    ELSE (parse*) @ EXECUTE _c LITN THEN
+    ELSE (parse*) @ EXECUTE LITN THEN
     AGAIN
 ; IMMEDIATE
 

forth/z80a.fs

@@ -2,7 +2,8 @@
 
 ( Splits word into msb/lsb, lsb being on TOS )
 : SPLITB
-    256 /MOD SWAP
+    DUP 0x100 /
+    SWAP 0xff AND
 ;
 
 ( To debug, change C, to .X )
@@ -32,9 +33,6 @@
 : IY+ _iy+- ;
 : IY- 0 -^ _iy+- ;
 
-: <<3 8 * ;
-: <<4 16 * ;
-
 ( -- )
 : OP1 CREATE C, DOES> C@ A, ;
 0x76 OP1 HALT,
@@ -51,7 +49,7 @@
     DOES>
     C@              ( r op )
     SWAP            ( op r )
-    <<3             ( op r<<3 )
+    8 *             ( op r<<3 )
     OR A,
 ;
 0x04 OP1r INCr,
@@ -75,7 +73,7 @@
     DOES>
     C@              ( qq op )
     SWAP            ( op qq )
-    <<4             ( op qq<<4 )
+    16 *            ( op qq<<4 )
     OR A,
 ;
 0xc5 OP1qq PUSHqq,
@@ -87,7 +85,7 @@
 : _1rr
     C@              ( rd rr op )
     ROT             ( rr op rd )
-    <<3             ( rr op rd<<3 )
+    8 *             ( rr op rd<<3 )
     OR OR A,
 ;
 
@@ -128,7 +126,7 @@
     DOES>
     C@              ( r n op )
     ROT             ( n op r )
-    <<3             ( n op r<<3 )
+    8 *             ( n op r<<3 )
     OR A, A,
 ;
 0x06 OP2rn LDrn,
@@ -140,7 +138,7 @@
     0xcb A,
     C@              ( b r op )
     ROT             ( r op b )
-    <<3             ( r op b<<3 )
+    8 *             ( r op b<<3 )
     OR OR A,
 ;
 0xc0 OP2br SETbr,
@@ -168,9 +166,9 @@
 : OP2r
     CREATE ,
     DOES>
-    @ SPLITB SWAP   ( r lsb msb )
+    @ 256 /MOD      ( r lsb msb )
     A,              ( r lsb )
-    SWAP <<3        ( lsb r<<3 )
+    SWAP 8 *        ( lsb r<<3 )
     OR A,
 ;
 0xed41 OP2r OUT(C)r,
@@ -182,7 +180,7 @@
     DOES>
     0xed A,
     C@ SWAP         ( op ss )
-    <<4             ( op ss<< 4 )
+    16 *            ( op ss<< 4 )
     OR A,
 ;
 0x4a OP2ss ADCHLss,
@@ -194,7 +192,7 @@
     DOES>
     C@              ( dd nn op )
     ROT             ( nn op dd )
-    <<4             ( nn op dd<<4 )
+    16 *            ( nn op dd<<4 )
     OR A,
     SPLITB A, A,
 ;
@@ -225,21 +223,6 @@
 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,12 +245,3 @@ CODE IMMED?
 ( notset )
     DE PUSHqq,
 ;CODE
-
-CODE BYE
-    HALT,
-;CODE
-
-CODE (resSP)
-    ( INITIAL_SP == JTBL+28 )
-    SP JTBL 28 + @ LDdd(nn),
-;CODE