forth: fix DOES> bad exec offset

forth: Add word "("
Also, fix "RECURSE" in IMMEDIATE contexts.
2024-11-26 09:18:05 +11:00 · 2020-03-13 21:27:19 -04:00 · 2020-03-13 19:33:16 -04:00 · 2020-03-13 16:40:55 -04:00 · 2020-03-13 16:01:09 -04:00
9 changed files with 297 additions and 155 deletions
--- a/apps/forth/core.fth
+++ b/apps/forth/core.fth
@ -1,16 +1,26 @@
 : H HERE @ ;
 : -^ SWAP - ;
-: ? @ . ;
 : +! SWAP OVER @ + SWAP ! ;
 : ALLOT HERE +! ;
-: VARIABLE CREATE 2 ALLOT ;
-: CONSTANT CREATE H ! DOES> @ ;
 : , H ! 2 ALLOT ;
 : C, H C! 1 ALLOT ;
-: IF ['] (fbr?) , H 0 C, ; IMMEDIATE
+: IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
 : THEN DUP H -^ SWAP C! ; IMMEDIATE
-: ELSE ['] (fbr) , 0 C, DUP H -^ SWAP C! H 1 - ; IMMEDIATE
+: ELSE ['] (fbr) , 1 ALLOT DUP H -^ SWAP C! H 1 - ; IMMEDIATE
+: RECURSE R> R> 2 - >R >R EXIT ;
+: ( LIT@ ) WORD SCMP IF RECURSE THEN ; IMMEDIATE
+( Hello, hello, krkrkrkr... do you hear me? )
+( Ah, voice at last! Some lines above need comments )
+( IF: write (fbr?) addr, push HERE, create cell )
+( THEN: Subtract TOS from H to get offset to write to cell )
+( in that same TOS's addr )
+( ELSE: write (fbr) addr, allot, then same as THEN )
+( RECURSE: RS TOS is for RECURSE itself, then we have to dig )
+( one more level to get to RECURSE's parent's caller. )
 : NOT IF 0 ELSE 1 THEN ;
+: ? @ . ;
+: VARIABLE CREATE 2 ALLOT ;
+: CONSTANT CREATE H ! DOES> @ ;
 : = CMP NOT ;
 : < CMP 0 1 - = ;
 : > CMP 1 = ;
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@ -7,43 +7,64 @@
 ;
 ; The code pointer point to "word routines". These routines expect to be called
 ; with IY pointing to the PF. They themselves are expected to end by jumping
-; to the address at the top of the Return Stack. They will usually do so with
-; "jp exit".
+; to the address at (IP). They will usually do so with "jp next".
 ;
 ; That's for "regular" words (words that are part of the dict chain). There are
 ; also "special words", for example NUMBER, LIT, FBR, that have a slightly
 ; different structure. They're also a pointer to an executable, but as for the
 ; other fields, the only one they have is the "flags" field.

+; This routine is jumped to at the end of every word. In it, we jump to current
+; IP, but we also take care of increasing it my 2 before jumping
+next:
+	; Before we continue: are stacks within bounds?
+	call	chkPSRS
+	ld	de, (IP)
+	ld	h, d
+	ld	l, e
+	inc	de \ inc de
+	ld	(IP), de
+	; HL is an atom list pointer. We need to go into it to have a wordref
+	ld	e, (hl)
+	inc	hl
+	ld	d, (hl)
+	push	de
+	jp	EXECUTE+2
+
+
 ; Execute a word containing native code at its PF address (PFA)
 nativeWord:
 	jp	(iy)

-; Execute a list of atoms, which usually ends with EXIT.
-; IY points to that list.
+; Execute a list of atoms, which always end with EXIT.
+; IY points to that list. What do we do:
+; 1. Push current IP to RS
+; 2. Set new IP to the second atom of the list
+; 3. Execute the first atom of the list.
 compiledWord:
+	ld	hl, (IP)
+	call	pushRS
 	push	iy \ pop hl
 	inc	hl
 	inc	hl
-	; HL points to next Interpreter pointer.
-	call	pushRS
+	ld	(IP), hl
+	; IY still is our atom reference...
 	ld	l, (iy)
 	ld	h, (iy+1)
-	push	hl \ pop iy
-	; IY points to code link
-	jp	executeCodeLink
+	push	hl	; argument for EXECUTE
+	jp	EXECUTE+2

 ; Pushes the PFA directly
 cellWord:
 	push	iy
-	jp	exit
+	jp	next

 ; Pushes the address in the first word of the PF
 sysvarWord:
 	ld	l, (iy)
 	ld	h, (iy+1)
 	push	hl
-	jp	exit
+	jp	next

 ; The word was spawned from a definition word that has a DOES>. PFA+2 (right
 ; after the actual cell) is a link to the slot right after that DOES>.
@ -59,20 +80,16 @@ doesWord:
 ; This is not a word, but a number literal. This works a bit differently than
 ; others: PF means nothing and the actual number is placed next to the
 ; numberWord reference in the compiled word list. What we need to do to fetch
-; that number is to play with the Return stack: We pop it, read the number, push
-; it to the Parameter stack and then push an increase Interpreter Pointer back
-; to RS.
+; that number is to play with the IP.
 numberWord:
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)	; (HL) is out number
 	ld	e, (hl)
 	inc	hl
 	ld	d, (hl)
 	inc	hl
-	ld	(ix), l
-	ld	(ix+1), h
+	ld	(IP), hl	; advance IP by 2
 	push	de
-	jp	exit
+	jp	next

 	.db	0b10		; Flags
 NUMBER:
@ -84,8 +101,7 @@ NUMBER:
 ; context. Only words expecting those literals will look for them. This is why
 ; the litWord triggers abort.
 litWord:
-	call	popRS
-	call	intoHL
+	ld	hl, (IP)
 	call	printstr	; let's print the word before abort.
 	ld	hl, .msg
 	call	printstr
@ -97,24 +113,17 @@ litWord:
 LIT:
 	.dw	litWord

+; Pop previous IP from Return stack and execute it.
 ; ( R:I -- )
-	.db ";"
-	.fill 7
+	.db	"EXIT"
+	.fill	3
 	.dw	0
+	.db	0
 EXIT:
 	.dw nativeWord
-; When we call the EXIT word, we have to do a "double exit" because our current
-; Interpreter pointer is pointing to the word *next* to our EXIT reference when,
-; in fact, we want to continue processing the one above it.
 	call	popRS
-exit:
-	; Before we continue: is SP within bounds?
-	call	chkPS
-	; we're good
-	call	popRS
-	; We have a pointer to a word
-	push	hl \ pop iy
-	jp	compiledWord
+	ld	(IP), hl
+	jp	next

 ; ( R:I -- )
 	.db "QUIT"
@ -133,9 +142,9 @@ quit:
 ABORT:
 	.dw nativeWord
 abort:
-	; Reinitialize PS (RS is reinitialized in forthInterpret
+	; Reinitialize PS (RS is reinitialized in forthInterpret)
 	ld	sp, (INITIAL_SP)
-	jp	forthRdLine
+	jp	forthRdLineNoOk
 ABORTREF:
 	.dw ABORT

@ -163,7 +172,7 @@ EMIT:
 	pop	hl
 	ld	a, l
 	call	stdioPutC
-	jp	exit
+	jp	next

 ; ( c port -- )
 	.db "PC!"
@ -175,7 +184,7 @@ PSTORE:
 	pop	bc
 	pop	hl
 	out	(c), l
-	jp	exit
+	jp	next

 ; ( port -- c )
 	.db "PC@"
@ -188,7 +197,7 @@ PFETCH:
 	ld	h, 0
 	in	l, (c)
 	push	hl
-	jp	exit
+	jp	next

 ; ( addr -- )
 	.db "EXECUTE"
@ -206,18 +215,24 @@ executeCodeLink:
 	; IY points to PFA
 	jp	(hl)	; go!

-	.db ":"
+
+	.db	";"
 	.fill	6
 	.dw	EXECUTE
 	.db	0
+ENDDEF:
+	.dw	nativeWord
+	jp	EXIT+2
+
+	.db ":"
+	.fill 6
+	.dw ENDDEF
+	.db 0
 DEFINE:
 	.dw nativeWord
 	call	entryhead
 	ld	de, compiledWord
-	ld	(hl), e
-	inc	hl
-	ld	(hl), d
-	inc	hl
+	call	DEinHL
 	; At this point, we've processed the name literal following the ':'.
 	; What's next? We have, in IP, a pointer to words that *have already
 	; been compiled by INTERPRET*. All those bytes will be copied as-is.
@ -225,10 +240,12 @@ DEFINE:
 	; skip compwords until EXIT is reached.
 	ex	de, hl		; DE is our dest
 	ld	(HERE), de	; update HERE
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)
 .loop:
-	call	HLPointsEXIT
+	push	de		; --> lvl 1
+	ld	de, ENDDEF
+	call	HLPointsDE
+	pop	de		; <-- lvl 1
 	jr	z, .loopend
 	call	compSkip
 	jr	.loop
@ -236,22 +253,19 @@ DEFINE:
 	; skip EXIT
 	inc	hl \ inc hl
 	; We have out end offset. Let's get our offset
-	ld	e, (ix)
-	ld	d, (ix+1)
+	ld	de, (IP)
 	or	a		; clear carry
 	sbc	hl, de
 	; HL is our copy count.
 	ld	b, h
 	ld	c, l
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)
 	ld	de, (HERE)	; recall dest
 	; copy!
 	ldir
-	ld	(ix), l
-	ld	(ix+1), h
+	ld	(IP), hl
 	ld	(HERE), de
-	jp	exit
+	jp	next


 	.db "DOES>"
@ -264,18 +278,16 @@ DOES:
 	; need to do.
 	; 1. Change the code link to doesWord
 	; 2. Leave 2 bytes for regular cell variable.
-	; 3. Get the Interpreter pointer from the stack and write this down to
-	;    entry PFA+2.
-	; 3. exit. Because we've already popped RS, a regular exit will abort
-	;    colon definition, so we're good.
+	; 3. Write down IP+2 to entry.
+	; 3. exit. we're done here.
 	ld	iy, (CURRENT)
 	ld	hl, doesWord
 	call	wrCompHL
 	inc	iy \ inc iy		; cell variable space
-	call	popRS
+	ld	hl, (IP)
 	call	wrCompHL
 	ld	(HERE), iy
-	jp	exit
+	jp	EXIT+2


 	.db "IMMEDIA"
@ -286,7 +298,7 @@ IMMEDIATE:
 	ld	hl, (CURRENT)
 	dec	hl
 	set	FLAG_IMMED, (hl)
-	jp	exit
+	jp	next

 ; ( n -- )
 	.db "LITERAL"
@ -300,7 +312,7 @@ LITERAL:
 	pop	de		; number from stack
 	call	DEinHL
 	ld	(HERE), hl
-	jp	exit
+	jp	next


 	.db	"'"
@ -313,7 +325,7 @@ APOS:
 	call	find
 	jr	nz, .notfound
 	push	de
-	jp	exit
+	jp	next
 .notfound:
 	ld	hl, .msg
 	call	printstr
@ -337,7 +349,7 @@ APOSI:
 	pop	de		; <-- lvl 1
 	call	DEinHL
 	ld	(HERE), hl
-	jp	exit
+	jp	next
 .notfound:
 	ld	hl, .msg
 	call	printstr
@ -356,23 +368,33 @@ KEY:
 	ld	h, 0
 	ld	l, a
 	push	hl
-	jp	exit
+	jp	next
+
+	.db "WORD"
+	.fill 3
+	.dw KEY
+	.db 0
+WORD:
+	.dw nativeWord
+	call	readword
+	jp	nz, abort
+	push	hl
+	jp	next

 	.db "CREATE"
 	.fill 1
-	.dw KEY
+	.dw WORD
 	.db 0
 CREATE:
 	.dw nativeWord
 	call	entryhead
-	jp	nz, quit
 	ld	de, cellWord
 	ld	(hl), e
 	inc	hl
 	ld	(hl), d
 	inc	hl
 	ld	(HERE), hl
-	jp	exit
+	jp	next

 	.db "HERE"
 	.fill 3
@ -399,11 +421,11 @@ DOT:
 	pop	de
 	; We check PS explicitly because it doesn't look nice to spew gibberish
 	; before aborting the stack underflow.
-	call	chkPS
+	call	chkPSRS
 	call	pad
 	call	fmtDecimalS
 	call	printstr
-	jp	exit
+	jp	next

 ; ( n a -- )
 	.db "!"
@ -416,7 +438,7 @@ STORE:
 	pop	hl
 	ld	(iy), l
 	ld	(iy+1), h
-	jp	exit
+	jp	next

 ; ( n a -- )
 	.db "C!"
@ -428,7 +450,7 @@ CSTORE:
 	pop	hl
 	pop	de
 	ld	(hl), e
-	jp	exit
+	jp	next

 ; ( a -- n )
 	.db "@"
@ -440,7 +462,7 @@ FETCH:
 	pop	hl
 	call	intoHL
 	push	hl
-	jp	exit
+	jp	next

 ; ( a -- c )
 	.db "C@"
@ -453,9 +475,8 @@ CFETCH:
 	ld	l, (hl)
 	ld	h, 0
 	push	hl
-	jp	exit
+	jp	next

-; ( -- a )
 	.db "LIT@"
 	.fill 3
 	.dw CFETCH
@ -464,7 +485,7 @@ LITFETCH:
 	.dw nativeWord
 	call	readLITTOS
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- b a )
 	.db "SWAP"
@ -476,7 +497,7 @@ SWAP:
 	pop	hl
 	ex	(sp), hl
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b c d -- c d a b )
 	.db "2SWAP"
@ -493,7 +514,7 @@ SWAP2:
 	push	de		; D
 	push	hl		; A
 	push	bc		; B
-	jp	exit
+	jp	next

 ; ( a -- a a )
 	.db "DUP"
@ -505,7 +526,7 @@ DUP:
 	pop	hl
 	push	hl
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- a b a b )
 	.db "2DUP"
@ -520,7 +541,7 @@ DUP2:
 	push	hl
 	push	de
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- a b a )
 	.db "OVER"
@ -534,7 +555,7 @@ OVER:
 	push	de
 	push	hl
 	push	de
-	jp	exit
+	jp	next

 ; ( a b c d -- a b c d a b )
 	.db "2OVER"
@ -553,12 +574,65 @@ OVER2:
 	push	hl	; D
 	push	iy	; A
 	push	bc	; B
-	jp	exit
+	jp	next
+
+	.db	">R"
+	.fill	5
+	.dw	OVER2
+	.db	0
+P2R:
+	.dw	nativeWord
+	pop	hl
+	call	pushRS
+	jp	next
+
+	.db	"R>"
+	.fill	5
+	.dw	P2R
+	.db	0
+R2P:
+	.dw	nativeWord
+	call	popRS
+	push	hl
+	jp	next
+
+	.db	"I"
+	.fill	6
+	.dw	R2P
+	.db	0
+I:
+	.dw	nativeWord
+	ld	l, (ix)
+	ld	h, (ix+1)
+	push	hl
+	jp	next
+
+	.db	"I'"
+	.fill	5
+	.dw	I
+	.db	0
+IPRIME:
+	.dw	nativeWord
+	ld	l, (ix-2)
+	ld	h, (ix-1)
+	push	hl
+	jp	next
+
+	.db	"J"
+	.fill	6
+	.dw	IPRIME
+	.db	0
+J:
+	.dw	nativeWord
+	ld	l, (ix-4)
+	ld	h, (ix-3)
+	push	hl
+	jp	next

 ; ( a b -- c ) A + B
 	.db "+"
 	.fill 6
-	.dw OVER2
+	.dw J
 	.db 0
 PLUS:
 	.dw nativeWord
@ -566,7 +640,7 @@ PLUS:
 	pop	de
 	add	hl, de
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- c ) A - B
 	.db "-"
@ -580,7 +654,7 @@ MINUS:
 	or	a		; reset carry
 	sbc	hl, de
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- c ) A * B
 	.db "*"
@ -593,7 +667,7 @@ MULT:
 	pop	bc
 	call	multDEBC
 	push	hl
-	jp	exit
+	jp	next

 ; ( a b -- c ) A / B
 	.db "/"
@ -606,7 +680,7 @@ DIV:
 	pop	hl
 	call	divide
 	push	bc
-	jp	exit
+	jp	next

 ; ( a1 a2 -- b )
 	.db "SCMP"
@ -620,7 +694,7 @@ SCMP:
 	call	strcmp
 	call	flagsToBC
 	push	bc
-	jp	exit
+	jp	next

 ; ( n1 n2 -- f )
 	.db "CMP"
@ -635,7 +709,7 @@ CMP:
 	sbc	hl, de
 	call	flagsToBC
 	push	bc
-	jp	exit
+	jp	next

 ; 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
@ -647,14 +721,12 @@ CMP:
 FBR:
 	.dw	nativeWord
 	push	de
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)
 	ld	a, (hl)
 	call	addHL
-	ld	(ix), l
-	ld	(ix+1), h
+	ld	(IP), hl
 	pop	de
-	jp	exit
+	jp	next

 ; Conditional branch, only branch if TOS is zero
 	.db	"(fbr?)"
@ -668,25 +740,11 @@ FBRC:
 	or	l
 	jr	z, FBR+2
 	; skip next byte in RS
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)
 	inc	hl
-	ld	(ix), l
-	ld	(ix+1), h
-	jp	exit
-
-
-	.db "RECURSE"
-	.dw FBRC
-	.db 0
-RECURSE:
-	.dw nativeWord
-	call	popRS
-	ld	l, (ix)
-	ld	h, (ix+1)
-	dec	hl \ dec hl
-	push	hl \ pop iy
-	jp	compiledWord
+	ld	(IP), hl
+	jp	next

 LATEST:
-	.dw RECURSE
+	.dw FBRC
+
--- a/apps/forth/dictionary.txt
+++ b/apps/forth/dictionary.txt
@ -36,7 +36,9 @@ directly, but as part of another word.
 ;           R:I --          Exit a colon definition
 ,           n --            Write n in HERE and advance it.
 ' x         -- a            Push addr of word x to a.
-['] x       --              *I* Like "'", but spits the addr as a number literal.
+['] x       --              *I* Like "'", but spits the addr as a number
+                            literal.
+(           --              *I* Comment. Ignore rest of line until ")" is read.
 ALLOT       n --            Move HERE by n bytes
 C,          b --            Write byte b in HERE and advance it.
 CREATE x    --              Create cell named x. Doesn't allocate a PF.
@ -60,7 +62,7 @@ QUIT        R:drop --       Return to interpreter promp immediately
 RECURSE     R:I -- R:I-2    Run the current word again.
 THEN        I:a --          *I* Set branching cell at a.

-*** Stack ***
+*** Parameter Stack ***
 DUP         a -- a a
 OVER        a b -- a b a
 SWAP        a b -- b a
@ -68,6 +70,13 @@ SWAP        a b -- b a
 2OVER       a b c d -- a b c d a b
 2SWAP       a b c d -- c d a b

+*** Return Stack ***
+>R          n -- R:n        Pops PS and push to RS
+R>          R:n -- n        Pops RS and push to PS
+I           -- n            Copy RS TOS to PS
+I'          -- n            Copy RS second item to PS
+J           -- n            Copy RS third item to PS
+
 *** Memory ***
@           a -- n          Set n to value at address a
 !           n a --          Store n in address a
@ -75,7 +84,7 @@ SWAP        a b -- b a
 +!          n a --          Increase value of addr a by n
 C@          a -- c          Set c to byte at address a
 C!          c a --          Store byte c in address a
-CURRENT     -- n            Set n to wordref of last added entry.
+CURRENT     -- a            Set a to wordref of last added entry.
 HERE        -- a            Push HERE's address
 H           -- a            HERE @

@ -96,8 +105,8 @@ CMP         n1 n2 -- n      Compare n1 and n2 and set n to -1, 0, or 1.
 NOT         f -- f          Push the logical opposite of f

 *** Strings ***
-LIT@ x      -- a            Read folloing LIT and push its addr to a
-S=          a1 a2 -- n      Compare strings a1 and a2. See CMP
+LIT@ x      -- a            Read following LIT and push its addr to a
+SCMP        a1 a2 -- n      Compare strings a1 and a2. See CMP

 *** I/O ***
 .           n --            Print n in its decimal form
@ -105,4 +114,5 @@ EMIT        c --            Spit char c to stdout
 KEY         -- c            Get char c from stdin
 PC!         c a --          Spit c to port a
 PC@         a -- c          Fetch c from port a
+WORD        -- a            Read one word from stdin and push its addr

--- a/apps/forth/main.asm
+++ b/apps/forth/main.asm
@ -17,9 +17,15 @@

 ; *** Variables ***
 .equ	INITIAL_SP	FORTH_RAMSTART
+; wordref of the last entry of the dict.
 .equ	CURRENT		@+2
+; Pointer to the next free byte in dict. During compilation of input text, this
+; temporarily points to the next free byte in COMPBUF.
 .equ	HERE		@+2
+; Used to hold HERE while we temporarily point it to COMPBUF
 .equ	OLDHERE		@+2
+; Interpreter pointer. See Execution model comment below.
+.equ	IP		@+2
 ; Pointer to where we currently are in the interpretation of the current line.
 .equ	INPUTPOS	@+2
 ; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
@ -59,6 +65,23 @@
 ;
 ; During IMMEDIATE mode, (HERE) is temporarily set to COMPBUF, and when we're
 ; done, we restore (HERE) for runtime. This way, everyone is happy.
+;
+; EXECUTING A WORD
+;
+; At it's core, executing a word is having the wordref in IY and call
+; executeCodeLink. Then, we let the word do its things. Some words are special,
+; but most of them are of the compiledWord type, and that's their execution that
+; we describe here.
+;
+; First of all, at all time during execution, the Interpreter Pointer (IP)
+; points to the wordref we're executing next.
+;
+; When we execute a compiledWord, the first thing we do is push IP to the Return
+; Stack (RS). Therefore, RS' top of stack will contain a wordref to execute
+; next, after we EXIT.
+;
+; At the end of every compiledWord is an EXIT. This pops RS, sets IP to it, and
+; continues.

 ; *** Code ***
 forthMain:
@ -82,10 +105,14 @@ forthMain:
 forthRdLine:
 	ld	hl, msgOk
 	call	printstr
+forthRdLineNoOk:
 	call	printcrlf
 	call	stdioReadLine
-	ld	ix, RS_ADDR-2		; -2 because we inc-before-push
 	ld	(INPUTPOS), hl
+	; Setup return stack. As a safety net, we set its bottom to ABORTREF.
+	ld	hl, ABORTREF
+	ld	(RS_ADDR), hl
+	ld	ix, RS_ADDR
 	; We're about to compile the line and possibly execute IMMEDIATE words.
 	; Let's save current (HERE) and temporarily set it to COMPBUF.
 	ld	hl, (HERE)
@ -128,11 +155,17 @@ forthInterpret:
 	ld	(HERE), de
 	jr	forthInterpret
 .immed:
-	push	hl		; --> lvl 1
-	ld	hl, .retRef
-	call	pushRS
-	pop	iy		; <-- lvl 1
-	jp	executeCodeLink
+	; For this IMMEDIATE word to be compatible with regular execution model,
+	; it needs to be compiled as an atom list. We need a temporary space for
+	; this, let's use (OLDHERE) while it isn't used.
+	ex	de, hl		; atom to write in DE
+	ld	hl, (OLDHERE)
+	call	DEinHL
+	; Now, let's write the .retRef
+	ld	de, .retRef
+	call	DEinHL
+	ld	iy, (OLDHERE)
+	jr	.execIY
 .execute:
 	ld	de, QUIT
 	call	.writeDE
@ -140,23 +173,25 @@ forthInterpret:
 	ld	hl, (OLDHERE)
 	ld	(HERE), hl
 	ld	iy, COMPBUF
+.execIY:
+	; before we execute, let's play with our RS a bit: compiledWord is
+	; going to push (IP) on the RS, but we don't expect our compiled words
+	; to ever return: it ends with QUIT. Let's set (IP) to ABORTREF and
+	; IX to RS_ADDR-2 so that compiledWord re-pushes our safety net.
+	ld	hl, ABORTREF
+	ld	(IP), hl
+	ld	ix, RS_ADDR-2
 	jp	compiledWord
 .writeDE:
 	push	hl
 	ld	hl, (HERE)
-	ld	(hl), e
-	inc	hl
-	ld	(hl), d
-	inc	hl
+	call	DEinHL
 	ld	(HERE), hl
 	pop	hl
 	ret

 .retRef:
-	.dw $+2
-	.dw $+2
-	call	popRS
-	jr	forthInterpret
+	.dw	forthInterpret

 msgOk:
 	.db	" ok", 0
--- a/apps/forth/stack.asm
+++ b/apps/forth/stack.asm
@ -36,8 +36,15 @@ skipRS:
 	pop	hl
 	ret

-; Verifies that SP is within bounds. If it's not, call ABORT
-chkPS:
+; Verifies that SP and RS are within bounds. If it's not, call ABORT
+chkPSRS:
+	push	ix \ pop hl
+	push	de		; --> lvl 1
+	ld	de, RS_ADDR
+	or	a		; clear carry
+	sbc	hl, de
+	pop	de		; <-- lvl 1
+	jr	c, .underflow
 	ld	hl, (INITIAL_SP)
 	; We have the return address for this very call on the stack. Let's
 	; compensate
@ -45,6 +52,7 @@ chkPS:
 	or	a		; clear carry
 	sbc	hl, sp
 	ret	nc		; (INITIAL_SP) >= SP? good
+.underflow:
 	; underflow
 	ld	hl, .msg
 	call	printstr
--- a/apps/forth/util.asm
+++ b/apps/forth/util.asm
@ -80,13 +80,6 @@ HLPointsBR:
 	pop	de
 	ret

-HLPointsEXIT:
-	push	de
-	ld	de, EXIT
-	call	HLPointsDE
-	pop	de
-	ret
-
 ; 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.
@ -202,20 +195,31 @@ readLIT:
 	.db "word expected", 0

 readLITBOS:
+	; Before we start: is our RS empty? If IX == RS_ADDR, it is (it only has
+	; its safety net). When that happens, we actually want to run readLITTOS
+	push	hl
 	push	de
-	ld	hl, (RS_ADDR)
+	push	ix \ pop hl
+	ld	de, RS_ADDR
+	or	a		; clear carry
+	sbc	hl, de
+	pop	de
+	pop	hl
+	jr	z, readLITTOS
+	push	de
+	; Our bottom-of-stack is RS_ADDR+2 because RS_ADDR is occupied by our
+	; ABORTREF safety net.
+	ld	hl, (RS_ADDR+2)
 	call	readLIT
-	ld	(RS_ADDR), de
+	ld	(RS_ADDR+2), de
 	pop	de
 	ret

 readLITTOS:
 	push	de
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	hl, (IP)
 	call	readLIT
-	ld	(ix), e
-	ld	(ix+1), d
+	ld	(IP), de
 	pop	de
 	ret

@ -284,7 +288,6 @@ entryhead:
 	inc	hl
 	ld	(CURRENT), hl
 	ld	(HERE), hl
-	xor	a		; set Z
 	ret

 ; Sets Z if wordref at HL is of the IMMEDIATE type
--- a/emul/.gitignore
+++ b/emul/.gitignore
@ -1,5 +1,6 @@
 /shell/shell
 /forth/stage1
+/forth/stage1dbg
 /forth/forth
 /zasm/zasm
 /zasm/avra
--- a/emul/Makefile
+++ b/emul/Makefile
@ -33,6 +33,9 @@ forth/forth0-bin.h: forth/forth0.bin
 forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h 
 	$(CC) forth/stage1.c $(OBJS) -o $@

+forth/stage1dbg: forth/stage1.c $(OBJS) forth/forth0-bin.h 
+	$(CC) -DDEBUG forth/stage1.c $(OBJS) -o $@
+
 forth/core.bin: $(APPS)/forth/core.fth forth/stage1
 	./forth/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null

--- a/emul/forth/stage1.c
+++ b/emul/forth/stage1.c
@ -20,6 +20,11 @@ directly follow executable's last byte so that we don't waste spce and also
 that wordref offsets correspond.
 */

+// When DEBUG is set, stage1 is a core-less forth that works interactively.
+// Useful for... debugging!
+// By the way: there's a double-echo in stagedbg. It's normal. Don't panic.
+
+//#define DEBUG
 // in sync with glue.asm
 #define RAMSTART 0x900
 #define STDIO_PORT 0x00
@ -44,11 +49,17 @@ static uint8_t iord_stdio()
 static void iowr_stdio(uint8_t val)
 {
    // we don't output stdout in stage0
+#ifdef DEBUG
+    // ... unless we're in DEBUG mode!
+    putchar(val);
+#endif
 }

 int main(int argc, char *argv[])
 {
-    bool tty = false;
+#ifdef DEBUG
+    fp = stdin;
+#else
    if (argc == 2) {
        fp = fopen(argv[1], "r");
        if (fp == NULL) {
@ -59,6 +70,7 @@ int main(int argc, char *argv[])
        fprintf(stderr, "Usage: ./stage0 filename\n");
        return 1;
    }
+#endif
    Machine *m = emul_init();
    m->ramstart = RAMSTART;
    m->iord[STDIO_PORT] = iord_stdio;
@ -74,6 +86,7 @@ int main(int argc, char *argv[])

    fclose(fp);

+#ifndef DEBUG
    // We're done, now let's spit dict data
    // let's start with LATEST spitting.
    putchar(m->mem[CURRENT]);
@ -82,6 +95,7 @@ int main(int argc, char *argv[])
    for (int i=sizeof(KERNEL); i<here; i++) {
        putchar(m->mem[i]);
    }
+#endif
    return 0;
 }
Author	SHA1	Message	Date
Virgil Dupras	94166186eb	forth: fix DOES> bad exec offset	2020-03-13 21:27:19 -04:00
Virgil Dupras	5b1ca474d4	forth: Add word "(" Also, fix "RECURSE" in IMMEDIATE contexts.	2020-03-13 19:33:16 -04:00
Virgil Dupras	d60ea4cb30	forth: Forth-ify RECURSE This comes with RS-modifying words. Also, this commit separates ";" from "EXIT", allowing EXIT to be used in definitions (was needed for RECURSE).	2020-03-13 16:40:55 -04:00
Virgil Dupras	c3838714d5	forth: improve execution model My approach with RS was slightly wrong: RS' TOP was always containing current IP. It worked, but it was problematic when came the time to introduce RS-modifying words: it's impossible to modify RS in a word without immediately messing your flow. Therefore, what used to be RS' TOS has to be a variable that isn't changed midway by RS-modifying words. I guess that's why RS is called return stack...	2020-03-13 16:01:09 -04:00