forth: Forth-ify "(print)"

Ain't that not self-bootstrapping enough to your taste? Whoa, I'm
getting dizzy...

emul/Makefile

@@ -103,7 +103,7 @@ updatebootstrap: $(ZASMBIN)
 # words and they write to HERE at initialization.
 .PHONY: fbootstrap
 fbootstrap: forth/stage2
-	cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
+	cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/icore.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
 
 .PHONY: clean
 clean:

forth/dictionary.txt

@@ -54,7 +54,7 @@ IMMEDIATE   --              Flag the latest defined word as immediate.
 LITN        n --            Write number n as a literal.
 [LITN]      n --            *I* Immediate version of LITN.
 ROUTINE x   -- a            Push the addr of the specified core routine
-                            C=cellWord L=compiledWord V=nativeWord N=next S=LIT
+                            C=cellWord J=JUMPTBL V=nativeWord N=next S=LIT
                             M=NUMBER Y=sysvarWord D=doesWord
 VARIABLE c  --              Creates cell x with 2 bytes allocation.
 

forth/forth.asm

@@ -10,6 +10,14 @@
 ; self-hosts in a more compact manner. File include is a big part of the
 ; complexity in zasm. If we can get rid of it, we'll be more compact.
 
+; *** ABI STABILITY ***
+;
+; This unit needs to have some of its entry points stay at a stable offset.
+; These have a comment over them indicating the expected offset. These should
+; not move until the Grand Bootstrapping operation has been completed.
+;
+; When you see random ".fill" here and there, it's to ensure that stability.
+
 ; *** Defines ***
 ; GETC: address of a GetC routine
 ; PUTC: address of a PutC routine
@@ -58,6 +66,8 @@
 .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
@@ -105,11 +115,17 @@
 ; change bootstrap binaries have to be adjusted because they rely on them.
 ; We're at 0 here
 	jp	forthMain
-.fill 0x17-$
+.fill 0x11-$
 JUMPTBL:
+	jp	pushRS
+	jp	popRS
 	jp	nativeWord
 	jp	next
 	jp	chkPS
+NUMBER:
+	.dw	numberWord
+LIT:
+	.dw	litWord
 
 ; *** Code ***
 forthMain:
@@ -137,6 +153,10 @@ forthMain:
 	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
@@ -160,6 +180,8 @@ forthMain:
 	.db	"(c<)", 0
 .emitName:
 	.db	"(emit)", 0
+.printName:
+	.db	"(print)", 0
 .keyName:
 	.db	"KEY", 0
 
@@ -175,31 +197,13 @@ BEGIN:
 
 INTERPRET:
 	.dw	compiledWord
-	; BBR mark
-	.dw	WORD
+	.dw	LIT
+	.db	"INTERPRET", 0
 	.dw	FIND_
-	.dw	CSKIP
-	.dw	FBR
-	.db	22
-	; It's a word, execute it
-	; For now, we only have one flag, let's take advantage of
-	; this to keep code simple.
-	.dw	NUMBER			; Bit 0 on
-	.dw	1
-	.dw	FLAGS_
-	.dw	STORE
+	.dw	DROP
 	.dw	EXECUTE
-	.dw	NUMBER			; Bit 0 off
-	.dw	0
-	.dw	FLAGS_
-	.dw	STORE
-	.dw	BBR
-	.db	29
-	; FBR mark, try number
-	.dw	PARSEI
-	.dw	BBR
-	.db	34
-	; infinite loop
+
+.fill 13
 
 ; *** Collapse OS lib copy ***
 ; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
@@ -625,9 +629,6 @@ numberWord:
 	push	de
 	jp	next
 
-NUMBER:
-	.dw	numberWord
-
 ; Similarly to numberWord, this is not a real word, but a string literal.
 ; Instead of being followed by a 2 bytes number, it's followed by a
 ; null-terminated string. When called, puts the string's address on PS
@@ -639,9 +640,6 @@ litWord:
 	ld	(IP), hl
 	jp	next
 
-LIT:
-	.dw	litWord
-
 ; Pop previous IP from Return stack and execute it.
 ; ( R:I -- )
 	.db	"EXIT"
@@ -691,8 +689,11 @@ abortUnderflow:
 .word:
 	.dw	compiledWord
 	.dw	LIT
-	.db	"stack underflow", 0
-	.dw	PRINT
+	.db	"stack underfl", 0
+	.dw	NUMBER
+	.dw	PRINTPTR
+	.dw	FETCH
+	.dw	EXECUTE
 	.dw	ABORT
 
 	.db "BYE"
@@ -702,6 +703,9 @@ BYE:
 	.dw nativeWord
 	halt
 
+; STABLE ABI
+; Offset: 02aa
+.out $
 ; ( c -- )
 	.db "EMIT"
 	.dw $-BYE
@@ -715,43 +719,10 @@ EMIT:
 	.dw	EXIT
 
 
-	.db	"(print)"
-	.dw	$-EMIT
-	.db	7
-PRINT:
-	.dw	compiledWord	; a
-	; BBR mark
-	.dw	DUP		; a a
-	.dw	.getc		; a c
-	.dw	DUP		; a c f
-	.dw	CSKIP		; a c
-	; zero, end of string
-	.dw	FBR
-	.db	12
-	.dw	EMIT		; a
-	.dw	NUMBER		; a 1
-	.dw	1
-	.dw	PLUS		; a+1
-	.dw	BBR
-	.db	21
-	; FBR mark
-	.dw	DROP
-	.dw	DROP
-	.dw	EXIT
-
-; Yes, very much like C@, but it has already been Forth-ified...
-.getc:
-	.dw	nativeWord
-	pop	hl
-	call	chkPS
-	ld	l, (hl)
-	ld	h, 0
-	push	hl
-	jp	next
-
+.fill 49
 
 	.db	"C,"
-	.dw	$-PRINT
+	.dw	$-EMIT
 	.db	2
 CWR:
 	.dw	nativeWord
@@ -794,13 +765,13 @@ ROUTINE:
 	ld	de, cellWord
 	cp	'C'
 	jr	z, .end
-	ld	de, compiledWord
-	cp	'L'
-	jr	z, .end
 	ld	de, JUMPTBL
+	cp	'J'
+	jr	z, .end
+	ld	de, JUMPTBL+6
 	cp	'V'
 	jr	z, .end
-	ld	de, JUMPTBL+3
+	ld	de, JUMPTBL+9
 	cp	'N'
 	jr	z, .end
 	ld	de, sysvarWord
@@ -815,7 +786,7 @@ ROUTINE:
 	ld	de, NUMBER
 	cp	'M'
 	jr	z, .end
-	ld	de, JUMPTBL+6
+	ld	de, JUMPTBL+12
 	cp	'P'
 	jr	nz, .notgood
 	; continue to end on match
@@ -835,6 +806,9 @@ ROUTINE:
 	.db "EXECUTE"
 	.dw $-ROUTINE
 	.db 7
+; STABLE ABI
+; Offset: 0388
+.out $
 EXECUTE:
 	.dw nativeWord
 	pop	iy	; is a wordref
@@ -848,22 +822,9 @@ EXECUTE:
 	jp	(hl)	; go!
 
 
-	.db	";"
-	.dw	$-EXECUTE
-	.db	0x81		; IMMEDIATE
-ENDDEF:
-	.dw	compiledWord
-	.dw	NUMBER
-	.dw	EXIT
-	.dw	WR
-	.dw	R2P		; exit COMPILE
-	.dw	DROP
-	.dw	R2P		; exit DEFINE
-	.dw	DROP
-	.dw	EXIT
-
+.fill 22
 	.db	":"
-	.dw	$-ENDDEF
+	.dw	$-EXECUTE
 	.db	0x81		; IMMEDIATE
 DEFINE:
 	.dw	compiledWord
@@ -983,6 +944,9 @@ SCPY:
 	.db	"(find)"
 	.dw	$-SCPY
 	.db	6
+; STABLE ABI
+; Offset: 047c
+.out $
 FIND_:
 	.dw	nativeWord
 	pop	hl
@@ -1070,6 +1034,9 @@ TOWORD:
 	.db "WORD"
 	.dw $-TOWORD
 	.db 4
+; STABLE ABI
+; Offset: 04f7
+.out $
 WORD:
 	.dw	compiledWord
 	.dw	NUMBER		; ( a )
@@ -1137,23 +1104,7 @@ PARSED:
 	jp	next
 
 
-	.db	"(parse)"
-	.dw	$-PARSED
-	.db	7
-PARSE:
-	.dw	compiledWord
-	.dw	PARSED
-	.dw	CSKIP
-	.dw	.error
-	; success, stack is already good, we can exit
-	.dw	EXIT
-
-.error:
-	.dw	compiledWord
-	.dw	LIT
-	.db	"unknown word", 0
-	.dw	PRINT
-	.dw	ABORT
+.fill 41
 
 
 ; Indirect parse caller. Reads PARSEPTR and calls
@@ -1168,7 +1119,7 @@ PARSEI:
 ; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
 ; HL points to new (HERE)
 	.db	"(entry)"
-	.dw	$-PARSE
+	.dw	$-PARSED
 	.db	7
 ENTRYHEAD:
 	.dw	compiledWord
@@ -1202,6 +1153,9 @@ ENTRYHEAD:
 	jp	next
 
 
+; STABLE ABI (every sysvars)
+; Offset: 05ca
+.out $
 	.db "HERE"
 	.dw $-ENTRYHEAD
 	.db 4
@@ -1241,6 +1195,9 @@ SYSVNXT_:
 	.db "!"
 	.dw $-SYSVNXT_
 	.db 1
+; STABLE ABI
+; Offset: 0610
+.out $
 STORE:
 	.dw nativeWord
 	pop	iy
@@ -1266,6 +1223,7 @@ FETCH:
 	.db "DROP"
 	.dw $-FETCH
 	.db 4
+; STABLE ABI
 DROP:
 	.dw nativeWord
 	pop	hl
@@ -1309,28 +1267,12 @@ OVER:
 	push	de
 	jp	next
 
-	.db	">R"
-	.dw	$-OVER
-	.db	2
-P2R:
-	.dw	nativeWord
-	pop	hl
-	call	chkPS
-	call	pushRS
-	jp	next
 
-	.db	"R>"
-	.dw	$-P2R
-	.db	2
-R2P:
-	.dw	nativeWord
-	call	popRS
-	push	hl
-	jp	next
+.fill 31
 
 ; ( a b -- c ) A + B
 	.db "+"
-	.dw $-R2P
+	.dw $-OVER
 	.db 1
 PLUS:
 	.dw nativeWord
@@ -1341,23 +1283,11 @@ PLUS:
 	push	hl
 	jp	next
 
-; ( a b -- c ) A - B
-	.db "-"
-	.dw $-PLUS
-	.db 1
-MINUS:
-	.dw nativeWord
-	pop	de		; B
-	pop	hl		; A
-	call	chkPS
-	or	a		; reset carry
-	sbc	hl, de
-	push	hl
-	jp	next
+.fill 18
 
 ; ( a1 a2 -- b )
 	.db "SCMP"
-	.dw $-MINUS
+	.dw $-PLUS
 	.db 4
 SCMP:
 	.dw nativeWord
@@ -1390,6 +1320,9 @@ CMP:
 	.db	"SKIP?"
 	.dw	$-CMP
 	.db	5
+; STABLE ABI
+; Offset: 06ee
+.out $
 CSKIP:
 	.dw	nativeWord
 	pop	hl
@@ -1447,6 +1380,9 @@ CSKIP:
 	.db	"(fbr)"
 	.dw	$-CSKIP
 	.db	5
+; STABLE ABI
+; Offset: 073e
+.out $
 FBR:
 	.dw	nativeWord
 	push	de
@@ -1460,6 +1396,9 @@ FBR:
 	.db	"(bbr)"
 	.dw	$-FBR
 	.db	5
+; STABLE ABI
+; Offset: 0757
+.out $
 BBR:
 	.dw	nativeWord
 	ld	hl, (IP)
@@ -1473,5 +1412,6 @@ BBR:
 ; 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	0
+	.db	5

forth/icore.fs

@@ -0,0 +1,85 @@
+( Inner core. This unit represents core definitions that
+  happen right after native definitions. Before core.fs.
+
+  Unlike core.fs and its followers, this unit isn't self-
+  sustained. Like native defs it uses the machinery of a
+  full Forth interpreter, notably for flow structures.
+
+  Because of that, it has to obey specific rules:
+
+  1. It cannot compile a word from higher layers. Using
+     immediates is fine though.
+  2. If it references a word from this unit or from native
+     definitions, these need to be properly offsetted
+     because their offset at compile time are not the same
+     as their runtime offsets.
+  3. Anything they refer to in the boot binary has to be
+     properly stabilized.
+  4. Make sure that the words you compile are not overridden
+     by the full interpreter.
+)
+
+( When referencing words from native defs or this very unit,
+  use this compiling word, which subtract the proper offset
+  from the compiled word. That proper offset is:
+  1. Take ROT-header addr, the first native def.
+  2. Subtract _bend, boot's last word.
+  3. That will give us the offset to subtract to get the addr
+     of our word at runtime.
+
+  This means, of course, that any word compiling a _c word
+  can't be executed immediately.
+)
+
+: _c
+    ['] ROT
+    6 -         ( header )
+    ['] _bend
+    -           ( our offset )
+    '           ( get word )
+    -^          ( apply offset )
+    ,           ( write! )
+; IMMEDIATE
+
+: 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? ABORT
+;
+
+( a -- )
+: (print)
+    BEGIN
+    DUP         ( a a )
+    _c C@       ( a c )
+    ( exit if null )
+    DUP NOT IF DROP DROP EXIT THEN
+    EMIT        ( a )
+    1 +         ( a+1 )
+    AGAIN
+;
+
+( ; has to be defined last because it can't be executed now )
+: X             ( can't have its real name now )
+    ['] EXIT ,
+    _c R> DROP     ( exit COMPILE )
+    _c R> DROP     ( exit : )
+; IMMEDIATE
+
+( Give ";" its real name )
+';' CURRENT @ 4 - C!
+

forth/z80c.fs

@@ -113,6 +113,15 @@ CODE XOR
     HL PUSHqq,
 ;CODE
 
+CODE -
+    DE POPqq,
+    HL POPqq,
+    chkPS,
+    A ORr,
+    DE SBCHLss,
+    HL PUSHqq,
+;CODE
+
 CODE *
     DE POPqq,
     BC POPqq,
@@ -207,3 +216,16 @@ CODE J
     H 3 IX- LDrIXY,
     HL PUSHqq,
 ;CODE
+
+CODE >R
+    HL POPqq,
+    chkPS,
+    ( JUMPTBL+0 == pushRS )
+    ROUTINE J CALLnn,
+;CODE
+
+CODE R>
+    ( JUMPTBL+3 == popRS )
+    ROUTINE J 3 + CALLnn,
+    HL PUSHqq,
+;CODE