apps/forth/core.fth

@@ -1,26 +1,16 @@
 : H HERE @ ;
 : -^ SWAP - ;
+: ? @ . ;
 : +! SWAP OVER @ + SWAP ! ;
 : ALLOT HERE +! ;
-: , H ! 2 ALLOT ;
-: C, H C! 1 ALLOT ;
-: IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
-: THEN DUP H -^ SWAP C! ; 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> @ ;
+: , H ! 2 ALLOT ;
+: C, H C! 1 ALLOT ;
+: IF ['] (fbr?) , H 0 C, ; IMMEDIATE
+: THEN DUP H -^ SWAP C! ; IMMEDIATE
+: ELSE ['] (fbr) , 0 C, DUP H -^ SWAP C! H 1 - ; IMMEDIATE
+: NOT IF 0 ELSE 1 THEN ;
 : = CMP NOT ;
 : < CMP 0 1 - = ;
 : > CMP 1 = ;

apps/forth/dict.asm

@@ -7,64 +7,43 @@
 ;
 ; 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 (IP). They will usually do so with "jp next".
+; to the address at the top of the Return Stack. They will usually do so with
+; "jp exit".
 ;
 ; 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 always end with EXIT.
+; Execute a list of atoms, which usually ends with EXIT.
-; IY points to that list. What do we do:
+; IY points to that list.
-; 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
-	ld	(IP), hl
+	; HL points to next Interpreter pointer.
-	; IY still is our atom reference...
+	call	pushRS
 	ld	l, (iy)
 	ld	h, (iy+1)
-	push	hl	; argument for EXECUTE
+	push	hl \ pop iy
-	jp	EXECUTE+2
+	; IY points to code link
+	jp	executeCodeLink
 
 ; Pushes the PFA directly
 cellWord:
 	push	iy
-	jp	next
+	jp	exit
 
 ; Pushes the address in the first word of the PF
 sysvarWord:
 	ld	l, (iy)
 	ld	h, (iy+1)
 	push	hl
-	jp	next
+	jp	exit
 
 ; 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>.
@@ -80,16 +59,20 @@ 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 IP.
+; 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.
 numberWord:
-	ld	hl, (IP)	; (HL) is out number
+	ld	l, (ix)
+	ld	h, (ix+1)
 	ld	e, (hl)
 	inc	hl
 	ld	d, (hl)
 	inc	hl
-	ld	(IP), hl	; advance IP by 2
+	ld	(ix), l
+	ld	(ix+1), h
 	push	de
-	jp	next
+	jp	exit
 
 	.db	0b10		; Flags
 NUMBER:
@@ -101,7 +84,8 @@ NUMBER:
 ; context. Only words expecting those literals will look for them. This is why
 ; the litWord triggers abort.
 litWord:
-	ld	hl, (IP)
+	call	popRS
+	call	intoHL
 	call	printstr	; let's print the word before abort.
 	ld	hl, .msg
 	call	printstr
@@ -113,17 +97,24 @@ litWord:
 LIT:
 	.dw	litWord
 
-; Pop previous IP from Return stack and execute it.
 ; ( R:I -- )
-	.db	"EXIT"
+	.db ";"
-	.fill	3
+	.fill 7
-	.dw	0
+	.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
-	ld	(IP), hl
+exit:
-	jp	next
+	; 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
 
 ; ( R:I -- )
 	.db "QUIT"
@@ -142,9 +133,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	forthRdLineNoOk
+	jp	forthRdLine
 ABORTREF:
 	.dw ABORT
 
@@ -172,7 +163,7 @@ EMIT:
 	pop	hl
 	ld	a, l
 	call	stdioPutC
-	jp	next
+	jp	exit
 
 ; ( c port -- )
 	.db "PC!"
@@ -184,7 +175,7 @@ PSTORE:
 	pop	bc
 	pop	hl
 	out	(c), l
-	jp	next
+	jp	exit
 
 ; ( port -- c )
 	.db "PC@"
@@ -197,7 +188,7 @@ PFETCH:
 	ld	h, 0
 	in	l, (c)
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( addr -- )
 	.db "EXECUTE"
@@ -215,24 +206,18 @@ executeCodeLink:
 	; IY points to PFA
 	jp	(hl)	; go!
 
-
-	.db	";"
-	.fill	6
-	.dw	EXECUTE
-	.db	0
-ENDDEF:
-	.dw	nativeWord
-	jp	EXIT+2
-
 	.db ":"
 	.fill 6
-	.dw ENDDEF
+	.dw EXECUTE
 	.db 0
 DEFINE:
 	.dw nativeWord
 	call	entryhead
 	ld	de, compiledWord
-	call	DEinHL
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
 	; 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.
@@ -240,12 +225,10 @@ DEFINE:
 	; skip compwords until EXIT is reached.
 	ex	de, hl		; DE is our dest
 	ld	(HERE), de	; update HERE
-	ld	hl, (IP)
+	ld	l, (ix)
+	ld	h, (ix+1)
 .loop:
-	push	de		; --> lvl 1
+	call	HLPointsEXIT
-	ld	de, ENDDEF
-	call	HLPointsDE
-	pop	de		; <-- lvl 1
 	jr	z, .loopend
 	call	compSkip
 	jr	.loop
@@ -253,19 +236,22 @@ DEFINE:
 	; skip EXIT
 	inc	hl \ inc hl
 	; We have out end offset. Let's get our offset
-	ld	de, (IP)
+	ld	e, (ix)
+	ld	d, (ix+1)
 	or	a		; clear carry
 	sbc	hl, de
 	; HL is our copy count.
 	ld	b, h
 	ld	c, l
-	ld	hl, (IP)
+	ld	l, (ix)
+	ld	h, (ix+1)
 	ld	de, (HERE)	; recall dest
 	; copy!
 	ldir
-	ld	(IP), hl
+	ld	(ix), l
+	ld	(ix+1), h
 	ld	(HERE), de
-	jp	next
+	jp	exit
 
 
 	.db "DOES>"
@@ -278,16 +264,18 @@ DOES:
 	; need to do.
 	; 1. Change the code link to doesWord
 	; 2. Leave 2 bytes for regular cell variable.
-	; 3. Write down IP+2 to entry.
+	; 3. Get the Interpreter pointer from the stack and write this down to
-	; 3. exit. we're done here.
+	;    entry PFA+2.
+	; 3. exit. Because we've already popped RS, a regular exit will abort
+	;    colon definition, so we're good.
 	ld	iy, (CURRENT)
 	ld	hl, doesWord
 	call	wrCompHL
 	inc	iy \ inc iy		; cell variable space
-	ld	hl, (IP)
+	call	popRS
 	call	wrCompHL
 	ld	(HERE), iy
-	jp	EXIT+2
+	jp	exit
 
 
 	.db "IMMEDIA"
@@ -298,7 +286,7 @@ IMMEDIATE:
 	ld	hl, (CURRENT)
 	dec	hl
 	set	FLAG_IMMED, (hl)
-	jp	next
+	jp	exit
 
 ; ( n -- )
 	.db "LITERAL"
@@ -312,7 +300,7 @@ LITERAL:
 	pop	de		; number from stack
 	call	DEinHL
 	ld	(HERE), hl
-	jp	next
+	jp	exit
 
 
 	.db	"'"
@@ -325,7 +313,7 @@ APOS:
 	call	find
 	jr	nz, .notfound
 	push	de
-	jp	next
+	jp	exit
 .notfound:
 	ld	hl, .msg
 	call	printstr
@@ -349,7 +337,7 @@ APOSI:
 	pop	de		; <-- lvl 1
 	call	DEinHL
 	ld	(HERE), hl
-	jp	next
+	jp	exit
 .notfound:
 	ld	hl, .msg
 	call	printstr
@@ -368,33 +356,23 @@ KEY:
 	ld	h, 0
 	ld	l, a
 	push	hl
-	jp	next
+	jp	exit
-
-	.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 WORD
+	.dw KEY
 	.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	next
+	jp	exit
 
 	.db "HERE"
 	.fill 3
@@ -421,11 +399,11 @@ DOT:
 	pop	de
 	; We check PS explicitly because it doesn't look nice to spew gibberish
 	; before aborting the stack underflow.
-	call	chkPSRS
+	call	chkPS
 	call	pad
 	call	fmtDecimalS
 	call	printstr
-	jp	next
+	jp	exit
 
 ; ( n a -- )
 	.db "!"
@@ -438,7 +416,7 @@ STORE:
 	pop	hl
 	ld	(iy), l
 	ld	(iy+1), h
-	jp	next
+	jp	exit
 
 ; ( n a -- )
 	.db "C!"
@@ -450,7 +428,7 @@ CSTORE:
 	pop	hl
 	pop	de
 	ld	(hl), e
-	jp	next
+	jp	exit
 
 ; ( a -- n )
 	.db "@"
@@ -462,7 +440,7 @@ FETCH:
 	pop	hl
 	call	intoHL
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a -- c )
 	.db "C@"
@@ -475,8 +453,9 @@ CFETCH:
 	ld	l, (hl)
 	ld	h, 0
 	push	hl
-	jp	next
+	jp	exit
 
+; ( -- a )
 	.db "LIT@"
 	.fill 3
 	.dw CFETCH
@@ -485,7 +464,7 @@ LITFETCH:
 	.dw nativeWord
 	call	readLITTOS
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- b a )
 	.db "SWAP"
@@ -497,7 +476,7 @@ SWAP:
 	pop	hl
 	ex	(sp), hl
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b c d -- c d a b )
 	.db "2SWAP"
@@ -514,7 +493,7 @@ SWAP2:
 	push	de		; D
 	push	hl		; A
 	push	bc		; B
-	jp	next
+	jp	exit
 
 ; ( a -- a a )
 	.db "DUP"
@@ -526,7 +505,7 @@ DUP:
 	pop	hl
 	push	hl
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- a b a b )
 	.db "2DUP"
@@ -541,7 +520,7 @@ DUP2:
 	push	hl
 	push	de
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- a b a )
 	.db "OVER"
@@ -555,7 +534,7 @@ OVER:
 	push	de
 	push	hl
 	push	de
-	jp	next
+	jp	exit
 
 ; ( a b c d -- a b c d a b )
 	.db "2OVER"
@@ -574,65 +553,12 @@ OVER2:
 	push	hl	; D
 	push	iy	; A
 	push	bc	; B
-	jp	next
+	jp	exit
-
-	.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 J
+	.dw OVER2
 	.db 0
 PLUS:
 	.dw nativeWord
@@ -640,7 +566,7 @@ PLUS:
 	pop	de
 	add	hl, de
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- c ) A - B
 	.db "-"
@@ -654,7 +580,7 @@ MINUS:
 	or	a		; reset carry
 	sbc	hl, de
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- c ) A * B
 	.db "*"
@@ -667,7 +593,7 @@ MULT:
 	pop	bc
 	call	multDEBC
 	push	hl
-	jp	next
+	jp	exit
 
 ; ( a b -- c ) A / B
 	.db "/"
@@ -680,7 +606,7 @@ DIV:
 	pop	hl
 	call	divide
 	push	bc
-	jp	next
+	jp	exit
 
 ; ( a1 a2 -- b )
 	.db "SCMP"
@@ -694,7 +620,7 @@ SCMP:
 	call	strcmp
 	call	flagsToBC
 	push	bc
-	jp	next
+	jp	exit
 
 ; ( n1 n2 -- f )
 	.db "CMP"
@@ -709,7 +635,7 @@ CMP:
 	sbc	hl, de
 	call	flagsToBC
 	push	bc
-	jp	next
+	jp	exit
 
 ; 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
@@ -721,12 +647,14 @@ CMP:
 FBR:
 	.dw	nativeWord
 	push	de
-	ld	hl, (IP)
+	ld	l, (ix)
+	ld	h, (ix+1)
 	ld	a, (hl)
 	call	addHL
-	ld	(IP), hl
+	ld	(ix), l
+	ld	(ix+1), h
 	pop	de
-	jp	next
+	jp	exit
 
 ; Conditional branch, only branch if TOS is zero
 	.db	"(fbr?)"
@@ -740,11 +668,25 @@ FBRC:
 	or	l
 	jr	z, FBR+2
 	; skip next byte in RS
-	ld	hl, (IP)
+	ld	l, (ix)
+	ld	h, (ix+1)
 	inc	hl
-	ld	(IP), hl
+	ld	(ix), l
-	jp	next
+	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
 
 LATEST:
-	.dw FBRC
+	.dw RECURSE
-

apps/forth/dictionary.txt

@@ -36,9 +36,7 @@ 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
+['] x       --              *I* Like "'", but spits the addr as a number literal.
-                            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.
@@ -62,7 +60,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.
 
-*** Parameter Stack ***
+*** Stack ***
 DUP         a -- a a
 OVER        a b -- a b a
 SWAP        a b -- b a
@@ -70,13 +68,6 @@ 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
@@ -84,7 +75,7 @@ J           -- n            Copy RS third item to PS
 +!          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     -- a            Set a to wordref of last added entry.
+CURRENT     -- n            Set n to wordref of last added entry.
 HERE        -- a            Push HERE's address
 H           -- a            HERE @
 
@@ -105,8 +96,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 following LIT and push its addr to a
+LIT@ x      -- a            Read folloing LIT and push its addr to a
-SCMP        a1 a2 -- n      Compare strings a1 and a2. See CMP
+S=          a1 a2 -- n      Compare strings a1 and a2. See CMP
 
 *** I/O ***
 .           n --            Print n in its decimal form
@@ -114,5 +105,4 @@ 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
 

apps/forth/main.asm

@@ -17,15 +17,9 @@
 
 ; *** 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.
@@ -65,23 +59,6 @@
 ;
 ; 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:
@@ -105,14 +82,10 @@ 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)
@@ -155,17 +128,11 @@ forthInterpret:
 	ld	(HERE), de
 	jr	forthInterpret
 .immed:
-	; For this IMMEDIATE word to be compatible with regular execution model,
+	push	hl		; --> lvl 1
-	; it needs to be compiled as an atom list. We need a temporary space for
+	ld	hl, .retRef
-	; this, let's use (OLDHERE) while it isn't used.
+	call	pushRS
-	ex	de, hl		; atom to write in DE
+	pop	iy		; <-- lvl 1
-	ld	hl, (OLDHERE)
+	jp	executeCodeLink
-	call	DEinHL
-	; Now, let's write the .retRef
-	ld	de, .retRef
-	call	DEinHL
-	ld	iy, (OLDHERE)
-	jr	.execIY
 .execute:
 	ld	de, QUIT
 	call	.writeDE
@@ -173,25 +140,23 @@ 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)
-	call	DEinHL
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
 	ld	(HERE), hl
 	pop	hl
 	ret
 
 .retRef:
-	.dw	forthInterpret
+	.dw $+2
+	.dw $+2
+	call	popRS
+	jr	forthInterpret
 
 msgOk:
 	.db	" ok", 0

apps/forth/stack.asm

@@ -36,15 +36,8 @@ skipRS:
 	pop	hl
 	ret
 
-; Verifies that SP and RS are within bounds. If it's not, call ABORT
+; Verifies that SP is within bounds. If it's not, call ABORT
-chkPSRS:
+chkPS:
-	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
@@ -52,7 +45,6 @@ chkPSRS:
 	or	a		; clear carry
 	sbc	hl, sp
 	ret	nc		; (INITIAL_SP) >= SP? good
-.underflow:
 	; underflow
 	ld	hl, .msg
 	call	printstr

apps/forth/util.asm

@@ -80,6 +80,13 @@ 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.
@@ -195,31 +202,20 @@ 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
-	push	ix \ pop hl
+	ld	hl, (RS_ADDR)
-	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+2), de
+	ld	(RS_ADDR), de
 	pop	de
 	ret
 
 readLITTOS:
 	push	de
-	ld	hl, (IP)
+	ld	l, (ix)
+	ld	h, (ix+1)
 	call	readLIT
-	ld	(IP), de
+	ld	(ix), e
+	ld	(ix+1), d
 	pop	de
 	ret
 
@@ -288,6 +284,7 @@ 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

emul/.gitignore

@@ -1,6 +1,5 @@
 /shell/shell
 /forth/stage1
-/forth/stage1dbg
 /forth/forth
 /zasm/zasm
 /zasm/avra

emul/Makefile

@@ -33,9 +33,6 @@ 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
 

emul/forth/stage1.c

@@ -20,11 +20,6 @@ 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
@@ -49,17 +44,11 @@ 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[])
 {
-#ifdef DEBUG
+    bool tty = false;
-    fp = stdin;
-#else
     if (argc == 2) {
         fp = fopen(argv[1], "r");
         if (fp == NULL) {
@@ -70,7 +59,6 @@ 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;
@@ -86,7 +74,6 @@ 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]);
@@ -95,7 +82,6 @@ int main(int argc, char *argv[])
     for (int i=sizeof(KERNEL); i<here; i++) {
         putchar(m->mem[i]);
     }
-#endif
     return 0;
 }