forth/core.fs

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

forth/dictionary.txt

@@ -100,7 +100,6 @@ 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,17 +122,6 @@ 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:
@@ -152,6 +141,20 @@ 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
@@ -160,14 +163,36 @@ forthMain:
 	push	de
 	jp	EXECUTE+2
 
+.parseName:
+	.db	"(parse)", 0
+.cinName:
+	.db	"(c<)", 0
+.keyName:
+	.db	"KEY", 0
 .bootName:
 	.db	"BOOT", 0
 
-.fill 101
+INTERPRET:
+	.dw	compiledWord
+	.dw	LIT
+	.db	"INTERPRET", 0
+	.dw	FIND_
+	.dw	DROP
+	.dw	EXECUTE
+
+.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
+; 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:
@@ -605,7 +630,23 @@ EXIT:
 	call	popRSIP
 	jp	next
 
-.fill 30
+; ( 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
 
 abortUnderflow:
 	ld	hl, .name
@@ -616,7 +657,7 @@ abortUnderflow:
 	.db "(uflw)", 0
 
 	.db	"(br)"
-	.dw	$-EXIT
+	.dw	$-QUIT
 	.db	4
 BR:
 	.dw	nativeWord
@@ -743,10 +784,24 @@ FIND_:
 	push	de
 	jp	next
 
-.fill 41
+; 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
 
 	.db	"NOT"
-	.dw	$-FIND_
+	.dw	$-CIN
 	.db	3
 NOT:
 	.dw	nativeWord
@@ -786,10 +841,178 @@ PARSED:
 	jp	next
 
 
-.fill 224
+.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
 
 	.db	"_bend"
-	.dw	$-PARSED
+	.dw	$-CMP
 	.db	5
-; Offset: 0647
+; Offset: 06ee
 .out $

forth/icore.fs

@@ -17,12 +17,6 @@
      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,
@@ -55,34 +49,7 @@
     ,           ( write! )
 ; IMMEDIATE
 
-: JTBL 0x08 ;
+: ABORT _c (resSP) QUIT ;
-
-: 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 )
@@ -93,12 +60,12 @@
 ( a -- )
 : (print)
     BEGIN
-    _c DUP      ( a a )
+    DUP         ( a a )
     _c C@       ( a c )
     ( exit if null )
-    _c DUP NOT IF _c 2DROP EXIT THEN
+    DUP NOT IF DROP DROP EXIT THEN
     _c EMIT     ( a )
-    1 _c +         ( a+1 )
+    1 +         ( a+1 )
     AGAIN
 ;
 
@@ -106,24 +73,19 @@
     LIT< stack-underflow _c (print) _c ABORT
 ;
 
-: C<
-    ( JTBL+40 == CINPTR )
-    [ JTBL 40 + @ LITN ] _c @ EXECUTE
-;
-
 : C,
-    _c HERE _c @ _c C!
+    HERE @ _c C!
-    _c HERE _c @ 1 _c + _c HERE _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 _c CMP 1 _c + NOT ;
+: WS? 33 CMP 1 + NOT ;
 
 : TOWORD
     BEGIN
-    _c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP
+    C< DUP _c WS? NOT IF EXIT THEN DROP
     AGAIN
 ;
 
@@ -136,30 +98,36 @@
     BEGIN
         ( We take advantage of the fact that char MSB is
           always zero to pre-write our null-termination )
-        _c OVER _c !            ( a )
+        OVER !                  ( a )
-        1 _c +                  ( a+1 )
+        1 +                     ( a+1 )
-        _c C<                   ( a c )
+        C<                      ( a c )
-        _c DUP _c WS?
+        DUP _c WS?
     UNTIL
     ( a this point, PS is: a WS )
     ( null-termination is already written )
-    _c 2DROP
+    DROP DROP
     [ JTBL 30 + @ LITN ]
 ;
 
+: LITN
+    ( JTBL+24 == NUMBER )
+    JTBL 24 + ,
+    ,
+;
+
 : (entry)
-    _c HERE _c @       ( h )
+    HERE @          ( h )
     _c WORD         ( h s )
     SCPY            ( h )
     ( Adjust HERE -1 because SCPY copies the null )
-    _c HERE _c @ 1 _c - ( h h' )
+    HERE @ 1 _c -   ( h h' )
-    _c DUP _c HERE _c ! ( h h' )
+    DUP HERE !      ( h h' )
-    _c SWAP _c -       ( sz )
+    SWAP _c -       ( sz )
     ( write prev value )
-    _c HERE _c @ _c CURRENT _c @ _c - ,
+    HERE @ CURRENT @ _c - ,
     ( write size )
     _c C,
-    _c HERE _c @ _c CURRENT _c !
+    HERE @ CURRENT !
 ;
 
 : INTERPRET
@@ -167,32 +135,20 @@
     _c WORD
     (find)
     IF
-        1 _c FLAGS _c !
+        1 FLAGS !
         EXECUTE
-        0 _c FLAGS _c !
+        0 FLAGS !
     ELSE
-        _c (parse*) _c @ EXECUTE
+        (parse*) @ EXECUTE
     THEN
     AGAIN
 ;
 
 : BOOT
-    LIT< (parse) (find) _c DROP _c (parse*) _c !
+    LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
-    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 )
@@ -206,15 +162,15 @@
     _c WORD
     (find)
     ( is word )
-    IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN
+    IF DUP _c IMMED? IF EXECUTE ELSE , THEN
     ( maybe number )
-    ELSE _c (parse*) _c @ EXECUTE _c LITN THEN
+    ELSE (parse*) @ EXECUTE _c LITN THEN
     AGAIN
 ; IMMEDIATE
 
 : Y
     ['] EXIT ,
-    _c R> _c DROP     ( exit : )
+    _c R> DROP     ( exit : )
 ; IMMEDIATE
 
 ( Give ":" and ";" their real name )

forth/z80a.fs

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

forth/z80c.fs

@@ -31,38 +31,6 @@ 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 )
@@ -74,12 +42,6 @@ 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
@@ -149,14 +111,6 @@ CODE XOR
     HL PUSHqq,
 ;CODE
 
-CODE +
-    HL POPqq,
-    DE POPqq,
-    chkPS,
-    DE ADDHLss,
-    HL PUSHqq,
-;CODE
-
 CODE -
     DE POPqq,
     HL POPqq,
@@ -213,25 +167,6 @@ 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,
@@ -319,31 +254,3 @@ 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
-