forth: Forth-ify "HERE", "CURRENT" and "JTBL"

forth.asm under 1K lines!

forth/core.fs

@@ -86,9 +86,14 @@
 
 : (sysv)
     (entry)
+    ( JTBL+0 == sysvarWord )
     [ JTBL LITN ] ,
-    SYSVNXT @ ,
-    2 SYSVNXT +!
+    ( JTBL+42 == SYSVNXT )
+    [ JTBL 42 + @ LITN ] DUP    ( a a )
+    ( Get new sysv addr )
+    @ ,                         ( a )
+    ( increase current sysv counter )
+    2 SWAP +!
 ;
 
 : ."

forth/dictionary.txt

@@ -100,6 +100,7 @@ DUP         a -- a a
 OVER        a b -- a b a
 ROT         a b c -- b c a
 SWAP        a b -- b a
+2DROP       a a --
 2DUP        a b -- a b a b
 2OVER       a b c d -- a b c d a b
 2SWAP       a b c d -- c d a b

forth/forth.asm

@@ -122,6 +122,17 @@ LIT:
 	.dw	litWord
 	.dw	INITIAL_SP
 	.dw	WORDBUF
+	jp	flagsToBC
+; 35
+	jp	strcmp
+	.dw	RS_ADDR
+	.dw	CINPTR
+	.dw	SYSVNXT
+	.dw	FLAGS
+; 46
+	.dw	PARSEPTR
+	.dw	HERE
+	.dw	CURRENT
 
 ; *** Code ***
 forthMain:
@@ -141,20 +152,6 @@ forthMain:
 	ld	(CURRENT), hl
 	ld	hl, HERE_INITIAL
 	ld	(HERE), hl
-	; Set up PARSEPTR
-	ld	hl, .parseName
-	call	find
-	ld	(PARSEPTR), de
-	; Set up CINPTR
-	; do we have a (c<) impl?
-	ld	hl, .cinName
-	call	find
-	jr	z, .skip
-	; no? then use KEY
-	ld	hl, .keyName
-	call	find
-.skip:
-	ld	(CINPTR), de
 	; Set up SYSVNXT
 	ld	hl, SYSVBUF
 	ld	(SYSVNXT), hl
@@ -163,36 +160,14 @@ forthMain:
 	push	de
 	jp	EXECUTE+2
 
-.parseName:
-	.db	"(parse)", 0
-.cinName:
-	.db	"(c<)", 0
-.keyName:
-	.db	"KEY", 0
 .bootName:
 	.db	"BOOT", 0
 
-INTERPRET:
-	.dw	compiledWord
-	.dw	LIT
-	.db	"INTERPRET", 0
-	.dw	FIND_
-	.dw	DROP
-	.dw	EXECUTE
-
-.fill 56
+.fill 101
 
 ; 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
-; transition, I make, right now, a copy of the routines actually used by Forth's
-; native core. This also has the effect of reducing binary size right now and
-; give us an idea of Forth's compactness.
-; These routines below are copy/paste from apps/lib and stdio.
-
 ; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
 ; ld must be done little endian, so least significant byte first.
 intoHL:
@@ -630,23 +605,7 @@ EXIT:
 	call	popRSIP
 	jp	next
 
-; ( R:I -- )
-	.db "QUIT"
-	.dw $-EXIT
-	.db 4
-QUIT:
-	.dw compiledWord
-	.dw	NUMBER
-	.dw	0
-	.dw	FLAGS_
-	.dw	STORE
-	.dw	.private
-	.dw	INTERPRET
-
-.private:
-	.dw	nativeWord
-	ld	ix, RS_ADDR
-	jp	next
+.fill 30
 
 abortUnderflow:
 	ld	hl, .name
@@ -657,7 +616,7 @@ abortUnderflow:
 	.db "(uflw)", 0
 
 	.db	"(br)"
-	.dw	$-QUIT
+	.dw	$-EXIT
 	.db	4
 BR:
 	.dw	nativeWord
@@ -784,24 +743,10 @@ FIND_:
 	push	de
 	jp	next
 
-; This is an indirect word that can be redirected through "CINPTR"
-; code: it is replaced in readln.fs.
-	.db "C<"
-	.dw $-FIND_
-	.db 2
-CIN:
-	.dw	compiledWord
-	.dw	NUMBER
-	.dw	CINPTR
-	.dw	FETCH
-	.dw	EXECUTE
-	.dw	EXIT
-
-
-.fill 24
+.fill 41
 
 	.db	"NOT"
-	.dw	$-CIN
+	.dw	$-FIND_
 	.db	3
 NOT:
 	.dw	nativeWord
@@ -841,178 +786,10 @@ PARSED:
 	jp	next
 
 
-.fill 96
-
-	.db	"JTBL"
-	.dw	$-PARSED
-	.db	4
-JTBL:
-	.dw	sysvarWord
-	.dw	JUMPTBL
-
-; STABLE ABI (every sysvars)
-; Offset: 05ca
-.out $
-	.db "HERE"
-	.dw $-JTBL
-	.db 4
-HERE_:	; Caution: conflicts with actual variable name
-	.dw sysvarWord
-	.dw HERE
-
-	.db "CURRENT"
-	.dw $-HERE_
-	.db 7
-CURRENT_:
-	.dw sysvarWord
-	.dw CURRENT
-
-	.db "(parse*)"
-	.dw $-CURRENT_
-	.db 8
-PARSEPTR_:
-	.dw sysvarWord
-	.dw PARSEPTR
-
-	.db	"FLAGS"
-	.dw	$-PARSEPTR_
-	.db	5
-FLAGS_:
-	.dw	sysvarWord
-	.dw	FLAGS
-
-	.db	"SYSVNXT"
-	.dw	$-FLAGS_
-	.db	7
-SYSVNXT_:
-	.dw	sysvarWord
-	.dw	SYSVNXT
-
-; ( n a -- )
-	.db "!"
-	.dw $-SYSVNXT_
-	.db 1
-; STABLE ABI
-; Offset: 0610
-.out $
-STORE:
-	.dw nativeWord
-	pop	iy
-	pop	hl
-	call	chkPS
-	ld	(iy), l
-	ld	(iy+1), h
-	jp	next
-
-; ( a -- n )
-	.db "@"
-	.dw $-STORE
-	.db 1
-FETCH:
-	.dw nativeWord
-	pop	hl
-	call	chkPS
-	call	intoHL
-	push	hl
-	jp	next
-
-; ( a -- )
-	.db "DROP"
-	.dw $-FETCH
-	.db 4
-; STABLE ABI
-DROP:
-	.dw nativeWord
-	pop	hl
-	jp	next
-
-; ( a b -- b a )
-	.db "SWAP"
-	.dw $-DROP
-	.db 4
-SWAP:
-	.dw nativeWord
-	pop	hl
-	call	chkPS
-	ex	(sp), hl
-	push	hl
-	jp	next
-
-; ( a -- a a )
-	.db "DUP"
-	.dw $-SWAP
-	.db 3
-DUP:
-	.dw nativeWord
-	pop	hl
-	call	chkPS
-	push	hl
-	push	hl
-	jp	next
-
-; ( a b -- a b a )
-	.db "OVER"
-	.dw $-DUP
-	.db 4
-OVER:
-	.dw nativeWord
-	pop	hl	; B
-	pop	de	; A
-	call	chkPS
-	push	de
-	push	hl
-	push	de
-	jp	next
-
-
-.fill 31
-
-; ( a b -- c ) A + B
-	.db "+"
-	.dw $-OVER
-	.db 1
-PLUS:
-	.dw nativeWord
-	pop	hl
-	pop	de
-	call	chkPS
-	add	hl, de
-	push	hl
-	jp	next
-
-.fill 18
-
-; ( a1 a2 -- b )
-	.db "SCMP"
-	.dw $-PLUS
-	.db 4
-SCMP:
-	.dw nativeWord
-	pop	de
-	pop	hl
-	call	chkPS
-	call	strcmp
-	call	flagsToBC
-	push	bc
-	jp	next
-
-; ( n1 n2 -- f )
-	.db "CMP"
-	.dw $-SCMP
-	.db 3
-CMP:
-	.dw nativeWord
-	pop	hl
-	pop	de
-	call	chkPS
-	or	a	; clear carry
-	sbc	hl, de
-	call	flagsToBC
-	push	bc
-	jp	next
+.fill 224
 
 	.db	"_bend"
-	.dw	$-CMP
+	.dw	$-PARSED
 	.db	5
-; Offset: 06ee
+; Offset: 0647
 .out $

forth/icore.fs

@@ -17,6 +17,12 @@
      properly stabilized.
   4. Make sure that the words you compile are not overridden
      by the full interpreter.
+  5. When using words as immediates, make sure that they're
+     not defined in icore or, if they are, make sure that
+     they contain no "_c" references.
+
+  All these rules make this unit a bit messy, but this is the
+  price to pay for the awesomeness of self-bootstrapping.
 )
 
 ( When referencing words from native defs or this very unit,
@@ -49,7 +55,34 @@
     ,           ( write! )
 ; IMMEDIATE
 
-: ABORT _c (resSP) QUIT ;
+: JTBL 0x08 ;
+
+: FLAGS
+    ( JTBL+44 == FLAGS )
+    [ JTBL 44 + @ LITN ]
+;
+
+: (parse*)
+    ( JTBL+46 == PARSEPTR )
+    [ JTBL 46 + @ LITN ]
+;
+
+: HERE
+    ( JTBL+48 == HERE )
+    [ JTBL 48 + @ LITN ]
+;
+
+: CURRENT
+    ( JTBL+50 == CURRENT )
+    [ JTBL 50 + @ LITN ]
+;
+
+: QUIT
+    0 _c FLAGS _c ! _c (resRS)
+    LIT< INTERPRET (find) _c DROP EXECUTE
+;
+
+: ABORT _c (resSP) _c QUIT ;
 
 ( This is only the "early parser" in earlier stages. No need
   for an abort message )
@@ -60,12 +93,12 @@
 ( a -- )
 : (print)
     BEGIN
-    DUP         ( a a )
+    _c DUP      ( a a )
     _c C@       ( a c )
     ( exit if null )
-    DUP NOT IF DROP DROP EXIT THEN
+    _c DUP NOT IF _c 2DROP EXIT THEN
     _c EMIT     ( a )
-    1 +         ( a+1 )
+    1 _c +         ( a+1 )
     AGAIN
 ;
 
@@ -73,19 +106,24 @@
     LIT< stack-underflow _c (print) _c ABORT
 ;
 
+: C<
+    ( JTBL+40 == CINPTR )
+    [ JTBL 40 + @ LITN ] _c @ EXECUTE
+;
+
 : C,
-    HERE @ _c C!
-    HERE @ 1 + HERE !
+    _c HERE _c @ _c C!
+    _c HERE _c @ 1 _c + _c HERE _c !
 ;
 
 ( 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 ;
+: WS? 33 _c CMP 1 _c + NOT ;
 
 : TOWORD
     BEGIN
-    C< DUP _c WS? NOT IF EXIT THEN DROP
+    _c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP
     AGAIN
 ;
 
@@ -98,36 +136,30 @@
     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?
+        _c OVER _c !            ( a )
+        1 _c +                  ( a+1 )
+        _c C<                   ( a c )
+        _c DUP _c WS?
     UNTIL
     ( a this point, PS is: a WS )
     ( null-termination is already written )
-    DROP DROP
+    _c 2DROP
     [ JTBL 30 + @ LITN ]
 ;
 
-: LITN
-    ( JTBL+24 == NUMBER )
-    JTBL 24 + ,
-    ,
-;
-
 : (entry)
-    HERE @          ( h )
+    _c HERE _c @       ( h )
     _c WORD         ( h s )
     SCPY            ( h )
     ( Adjust HERE -1 because SCPY copies the null )
-    HERE @ 1 _c -   ( h h' )
-    DUP HERE !      ( h h' )
-    SWAP _c -       ( sz )
+    _c HERE _c @ 1 _c - ( h h' )
+    _c DUP _c HERE _c ! ( h h' )
+    _c SWAP _c -       ( sz )
     ( write prev value )
-    HERE @ CURRENT @ _c - ,
+    _c HERE _c @ _c CURRENT _c @ _c - ,
     ( write size )
     _c C,
-    HERE @ CURRENT !
+    _c HERE _c @ _c CURRENT _c !
 ;
 
 : INTERPRET
@@ -135,20 +167,32 @@
     _c WORD
     (find)
     IF
-        1 FLAGS !
+        1 _c FLAGS _c !
         EXECUTE
-        0 FLAGS !
+        0 _c FLAGS _c !
     ELSE
-        (parse*) @ EXECUTE
+        _c (parse*) _c @ EXECUTE
     THEN
     AGAIN
 ;
 
 : BOOT
-    LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
+    LIT< (parse) (find) _c DROP _c (parse*) _c !
+    LIT< (c<) (find) NOT IF LIT< KEY (find) _c DROP THEN
+    ( JTBL+40 == CINPTR )
+    [ JTBL 40 + @ LITN ] _c !
+    LIT< (c<$) (find) IF EXECUTE ELSE _c DROP THEN
     _c INTERPRET
 ;
 
+( LITN has to be defined after the last immediate usage of
+  it to avoid bootstrapping issues )
+: LITN
+    ( JTBL+24 == NUMBER )
+    _c JTBL 24 _c + ,
+    ,
+;
+
 ( : and ; have to be defined last because it can't be
   executed now also, they can't have their real name
   right away )
@@ -162,15 +206,15 @@
     _c WORD
     (find)
     ( is word )
-    IF DUP _c IMMED? IF EXECUTE ELSE , THEN
+    IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN
     ( maybe number )
-    ELSE (parse*) @ EXECUTE _c LITN THEN
+    ELSE _c (parse*) _c @ EXECUTE _c LITN THEN
     AGAIN
 ; IMMEDIATE
 
 : Y
     ['] EXIT ,
-    _c R> DROP     ( exit : )
+    _c R> _c DROP     ( exit : )
 ; IMMEDIATE
 
 ( Give ":" and ";" their real name )

forth/z80a.fs

@@ -37,6 +37,7 @@
 
 ( -- )
 : OP1 CREATE C, DOES> C@ A, ;
+0xeb OP1 EXDEHL,
 0x76 OP1 HALT,
 0xc9 OP1 RET,
 0x17 OP1 RLA,

forth/z80c.fs

@@ -31,6 +31,38 @@ CODE ROT
     BC PUSHqq,      ( A )
 ;CODE
 
+( a -- a a )
+CODE DUP
+    HL POPqq,       ( A )
+    chkPS,
+    HL PUSHqq,      ( A )
+    HL PUSHqq,      ( A )
+;CODE
+
+( a -- )
+CODE DROP
+    HL POPqq,
+;CODE
+
+( a b -- b a )
+CODE SWAP
+    HL POPqq,       ( B )
+    DE POPqq,       ( A )
+    chkPS,
+    HL PUSHqq,      ( B )
+    DE PUSHqq,      ( A )
+;CODE
+
+( a b -- a b a )
+CODE OVER
+    HL POPqq,       ( B )
+    DE POPqq,       ( A )
+    chkPS,
+    DE PUSHqq,      ( A )
+    HL PUSHqq,      ( B )
+    DE PUSHqq,      ( A )
+;CODE
+
 ( a b -- a b a b )
 CODE 2DUP
     HL POPqq,       ( B )
@@ -42,6 +74,12 @@ CODE 2DUP
     HL PUSHqq,      ( B )
 ;CODE
 
+( a b -- )
+CODE 2DROP
+    HL POPqq,
+    HL POPqq,
+;CODE
+
 ( a b c d -- a b c d a b )
 
 CODE 2OVER
@@ -111,6 +149,14 @@ CODE XOR
     HL PUSHqq,
 ;CODE
 
+CODE +
+    HL POPqq,
+    DE POPqq,
+    chkPS,
+    DE ADDHLss,
+    HL PUSHqq,
+;CODE
+
 CODE -
     DE POPqq,
     HL POPqq,
@@ -167,6 +213,25 @@ CODE /MOD
     BC PUSHqq,
 ;CODE
 
+CODE !
+    HL POPqq,
+    DE POPqq,
+    chkPS,
+    (HL) E LDrr,
+    HL INCss,
+    (HL) D LDrr,
+;CODE
+
+CODE @
+    HL POPqq,
+    chkPS,
+    E (HL) LDrr,
+    HL INCss,
+    D (HL) LDrr,
+    EXDEHL,
+    HL PUSHqq,
+;CODE
+
 CODE C!
     HL POPqq,
     DE POPqq,
@@ -254,3 +319,31 @@ CODE (resSP)
     ( INITIAL_SP == JTBL+28 )
     SP JTBL 28 + @ LDdd(nn),
 ;CODE
+
+CODE (resRS)
+    ( RS_ADDR == JTBL+38 )
+    IX JTBL 38 + @ LDddnn,
+;CODE
+
+CODE SCMP
+    DE  POPqq,
+    HL  POPqq,
+    chkPS,
+    ( JTBL+35 == strcmp )
+    JTBL 35 + CALLnn,
+    ( JTBL+32 == flagsToBC )
+    JTBL 32 + CALLnn,
+    BC PUSHqq,
+;CODE
+
+CODE CMP
+    HL  POPqq,
+    DE  POPqq,
+    chkPS,
+    A ORr,      ( clear carry )
+    DE SBCHLss,
+    ( JTBL+32 == flagsToBC )
+    JTBL 32 + CALLnn,
+    BC PUSHqq,
+;CODE
+