forth: add string and logic routines, as well as "RECURSE"

The goal was to be able to implement "(" in forth, but I realised that my
INTERPRET approach was wrong. Compiling the line beforehand is, after all,
not good. I'll have to change it again.

apps/forth/dict.asm

@@ -211,10 +211,33 @@ EMIT:
 	call	stdioPutC
 	jp	exit
 
+; ( c port -- )
+	.db "PC!"
+	.fill 5
+	.dw EMIT
+PSTORE:
+	.dw nativeWord
+	pop	bc
+	pop	hl
+	out	(c), l
+	jp	exit
+
+; ( port -- c )
+	.db "PC@"
+	.fill 5
+	.dw PSTORE
+PFETCH:
+	.dw nativeWord
+	pop	bc
+	ld	h, 0
+	in	l, (c)
+	push	hl
+	jp	exit
+
 ; ( addr -- )
 	.db "EXECUTE"
 	.db 0
-	.dw EMIT
+	.dw PFETCH
 EXECUTE:
 	.dw nativeWord
 	pop	iy	; is a wordref
@@ -259,9 +282,7 @@ DEFINE:
 	; is lit
 	ldi
 	ldi
-	inc	hl \ inc hl
 	call	strcpyM
-	inc	hl		; byte after word termination
 	jr	.loop
 .notLIT:
 	; it's a word
@@ -286,7 +307,7 @@ DEFINE:
 	; a good old regular word. We have 2 bytes to copy. But before we do,
 	; let's check whether it's an EXIT. LDI doesn't affect Z, so we can
 	; make our jump later.
-	call	HLPointsEXIT
+	call	HLPointsEXITQUIT
 	ldi
 	ldi
 	jr	nz, .loop
@@ -464,10 +485,20 @@ FETCH:
 	push	hl
 	jp	exit
 
+; ( -- a )
+	.db "LIT@"
+	.fill 4
+	.dw FETCH
+LITFETCH:
+	.dw nativeWord
+	call	readLITTOS
+	push	hl
+	jp	exit
+
 ; ( a b -- b a )
 	.db "SWAP"
 	.fill 4
-	.dw FETCH
+	.dw LITFETCH
 SWAP:
 	.dw nativeWord
 	pop	hl
@@ -548,9 +579,36 @@ DIV:
 	push	bc
 	jp	exit
 
+; ( a1 a2 -- b )
+	.db "SCMP"
+	.fill 4
+	.dw DIV
+SCMP:
+	.dw nativeWord
+	pop	de
+	pop	hl
+	call	strcmp
+	call	flagsToBC
+	push	bc
+	jp	exit
+
+; ( n1 n2 -- f )
+	.db "CMP"
+	.fill 5
+	.dw SCMP
+CMP:
+	.dw nativeWord
+	pop	hl
+	pop	de
+	or	a	; clear carry
+	sbc	hl, de
+	call	flagsToBC
+	push	bc
+	jp	exit
+
 	.db "IF"
 	.fill 6
-	.dw DIV
+	.dw CMP
 IF:
 	.dw ifWord
 
@@ -566,13 +624,25 @@ ELSE:
 THEN:
 	.dw thenWord
 
+	.db "RECURSE"
+	.db 0
+	.dw THEN
+RECURSE:
+	.dw nativeWord
+	call	popRS
+	ld	l, (ix)
+	ld	h, (ix+1)
+	dec	hl \ dec hl
+	push	hl \ pop iy
+	jp	compiledWord
+
 ; End of native words
 
 ; ( a -- )
 ; @ .
 	.db "?"
 	.fill 7
-	.dw THEN
+	.dw RECURSE
 FETCHDOT:
 	.dw compiledWord
 	.dw FETCH
@@ -631,3 +701,59 @@ CONSTANT:
 	.dw DOES
 	.dw FETCH
 	.dw EXIT
+
+; ( f -- f )
+; IF 0 ELSE 1 THEN
+	.db "NOT"
+	.fill 5
+	.dw CONSTANT
+NOT:
+	.dw compiledWord
+	.dw IF
+	.dw NUMBER
+	.dw 0
+	.dw ELSE
+	.dw NUMBER
+	.dw 1
+	.dw THEN
+	.dw EXIT
+
+; ( n1 n2 -- f )
+; CMP NOT
+	.db "="
+	.fill 7
+	.dw NOT
+EQ:
+	.dw compiledWord
+	.dw CMP
+	.dw NOT
+	.dw EXIT
+
+; ( n1 n2 -- f )
+; CMP -1 =
+	.db "<"
+	.fill 7
+	.dw EQ
+LT:
+	.dw compiledWord
+	.dw CMP
+	.dw NUMBER
+	.dw -1
+	.dw EQ
+	.dw EXIT
+
+; ( n1 n2 -- f )
+; CMP 1 =
+	.db ">"
+	.fill 7
+	.dw LT
+GT:
+LATEST:
+	.dw compiledWord
+	.dw CMP
+	.dw NUMBER
+	.dw 1
+	.dw EQ
+	.dw EXIT
+
+;

apps/forth/dictionary.txt

@@ -43,6 +43,7 @@ IF          n --            Branch to ELSE or THEN if n is zero
 INTERPRET   --              Get a line from stdin, compile it in tmp memory,
                             then execute the compiled contents.
 QUIT        R:drop --       Return to interpreter promp immediately
+RECURSE     R:I -- R:I-2    Run the current word again.
 THEN        --              Does nothing. Serves as a branching merker for IF
                             and ELSE.
 
@@ -66,8 +67,22 @@ HERE        -- a            Push HERE's address
 *           a b -- c        a * b -> c
 /           a b -- c        a / b -> c
 
+*** Logic ***
+=           n1 n2 -- f      Push true if n1 == n2
+<           n1 n2 -- f      Push true if n1 < n2
+>           n1 n2 -- f      Push true if n1 > n2
+CMP         n1 n2 -- n      Compare n1 and n2 and set n to -1, 0, or 1.
+                            n=0: a1=a2. n=1: a1>a2. n=-1: a1<a2.
+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
+
 *** I/O ***
 .           n --            Print n in its decimal form
 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
 

apps/forth/main.asm

@@ -27,7 +27,7 @@ forthMain:
 	; we check for stack underflow.
 	push	af \ push af \ push af
 	ld	(INITIAL_SP), sp
-	ld	hl, CONSTANT		; last entry in hardcoded dict
+	ld	hl, LATEST
 	ld	(CURRENT), hl
 	ld	hl, FORTH_RAMEND
 	ld	(HERE), hl

apps/forth/util.asm

@@ -69,10 +69,14 @@ HLPointsLIT:
 	pop	de
 	ret
 
-HLPointsEXIT:
+HLPointsEXITQUIT:
 	push	de
 	ld	de, EXIT
 	call	HLPointsDE
+	jr	z, .end
+	ld	de, QUIT
+	call	HLPointsDE
+.end:
 	pop	de
 	ret
 
@@ -98,21 +102,22 @@ compSkip:
 	inc	hl \ inc hl
 	ret
 
+; ***readLIT***
 ; The goal of this routine is to read a string literal following the currently
 ; executed words. For example, CREATE and DEFINE need this. Things are a little
 ; twisted, so bear with me while I explain how it works.
 ;
 ; When we call this routine, everything has been compiled. We're on an atom and
 ; we're executing it. Now, we're looking for a string literal or a word-with-a
-; name that follows our readCompWord caller. We could think that this word is
+; name that follows our readLIT caller. We could think that this word is
-; right there on RS' TOS, but no! You have to account for words wrapping the
+; right there on RS' TOS, but not always! You have to account for words wrapping
-; caller. For example, "VARIABLE" calls "CREATE". If you call "VARIABLE foo",
+; the caller. For example, "VARIABLE" calls "CREATE". If you call
-; if CREATE looks at what follows in RS' TOS, it will only find the "2" in
+; "VARIABLE foo", if CREATE looks at what follows in RS' TOS, it will only find
-; "CREATE 2 ALLOT".
+; the "2" in "CREATE 2 ALLOT".
 ;
-; Therefore, we actually need to check in RS' *bottom of stack* for our answer.
+; In this case, we actually need to check in RS' *bottom of stack* for our
-; If that atom is a LIT, we're good. We make HL point to it and advance IP to
+; answer. If that atom is a LIT, we're good. We make HL point to it and advance
-; byte following null-termination.
+; IP to byte following null-termination.
 ;
 ; If it isn't, things get interesting: If it's a word reference, then it's
 ; not an invalid literal. For example, one could want to redefine an existing
@@ -123,31 +128,48 @@ compSkip:
 ; second word in our dict. We don't accept EXIT because it's the termination
 ; word. Yeah, it means that ";" can't be overridden...
 ; If name can't be read, we abort
-readCompWord:
+;
-	; In all cases, we want RS' BOS in HL. Let's get it now.
+; BOS vs TOS: What we cover so far is the "CREATE" and friends cases, where we
-	ld	hl, (RS_ADDR)
+; want to read BOS. There are, however, cases where we want to read TOS, that is
+; that we want to read the LIT right next to our atom. Example: "(". When
+; processing comments, we are at compile time and want to read words from BOS,
+; yes), however, in "("'s definition, there's "LIT@ )", which means "fetch LIT
+; next to me and push this to stack". This LIT we want to fetch is *not* from
+; BOS, it's from TOS.
+;
+; This is why we have readLITBOS and readLITTOS. readLIT uses HL and DE and is
+; not used directly.
+
+; Given a RS stack pointer HL, read LIT next to it (or abort) and set HL to
+; point to its associated string. Set DE to there the RS stack pointer should
+; point next.
+readLIT:
 	call	HLPointsLIT
 	jr	nz, .notLIT
 	; RS BOS is a LIT, make HL point to string, then skip this RS compword.
 	inc	hl \ inc hl	; HL now points to string itself
-	push	hl		; --> lvl 1, our result
+	; HL has our its final value
+	ld	d, h
+	ld	e, l
 	call	strskip
 	inc	hl		; byte after word termination
-	ld	(RS_ADDR), hl
+	ex	de, hl
-	pop	hl		; <-- lvl 1, our result
 	ret
 .notLIT:
 	; Alright, not a literal, but is it a word? If it's not a number, then
 	; it's a word.
 	call	HLPointsNUMBER
 	jr	z, .notWord
+	call	HLPointsEXITQUIT
+	jr	z, .notWord
 	; Not a number, then it's a word. Copy word to pad and point to it.
+	push	hl		; --> lvl 1. we need it to set DE later
 	call	intoHL
 	or	a		; clear carry
 	ld	de, CODELINK_OFFSET
 	sbc	hl, de
 	; That's our return value
-	push	hl		; --> lvl 1
+	push	hl		; --> lvl 2
 	; HL now points to word offset, let'd copy it to pad
 	ex	de, hl
 	call	pad
@@ -157,10 +179,10 @@ readCompWord:
 	; null-terminate
 	xor	a
 	ld	(de), a
-	; Advance RS' BOS by 2
+	pop	hl		; <-- lvl 2
-	ld	hl, RS_ADDR
+	pop	de		; <-- lvl 1
-	inc	(hl) \ inc (hl)
+	; Advance IP by 2
-	pop	hl		; <-- lvl 1
+	inc	de \ inc de
 	ret
 .notWord:
 	ld	hl, .msg
@@ -169,6 +191,24 @@ readCompWord:
 .msg:
 	.db "word expected", 0
 
+readLITBOS:
+	push	de
+	ld	hl, (RS_ADDR)
+	call	readLIT
+	ld	(RS_ADDR), de
+	pop	de
+	ret
+
+readLITTOS:
+	push	de
+	ld	l, (ix)
+	ld	h, (ix+1)
+	call	readLIT
+	ld	(ix), e
+	ld	(ix+1), d
+	pop	de
+	ret
+
 ; For DE being a wordref, move DE to the previous wordref.
 ; Z is set if DE point to 0 (no entry). NZ if not.
 prev:
@@ -238,7 +278,7 @@ compile:
 	; When encountering an undefined word during compilation, we spit a
 	; reference to litWord, followed by the null-terminated word.
 	; This way, if a preceding word expect a string literal, it will read it
-	; by calling readCompWord, and if it doesn't, the routine will be
+	; by calling readLIT, and if it doesn't, the routine will be
 	; called, triggering an abort.
 	ld	hl, LIT
 	call	wrCompHL
@@ -256,7 +296,7 @@ compile:
 ; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
 ; HL points to new (HERE)
 entryhead:
-	call	readCompWord
+	call	readLITBOS
 	ld	de, (HERE)
 	call	strcpy
 	ex	de, hl		; (HERE) now in HL
@@ -291,3 +331,15 @@ HLPointsIMMED:
 	inc	hl
 	pop	hl
 	ret
+
+; Checks flags Z and C and sets BC to 0 if Z, 1 if C and -1 otherwise
+flagsToBC:
+	ld	bc, 0
+	ret	z	; equal
+	inc	bc
+	ret	c	; >
+	; <
+	dec	bc
+	dec	bc
+	ret
+

apps/lib/util.asm

@@ -52,7 +52,7 @@ strcpy:
 	ret
 
 ; Compares strings pointed to by HL and DE until one of them hits its null char.
-; If equal, Z is set. If not equal, Z is reset.
+; If equal, Z is set. If not equal, Z is reset. C is set if HL > DE
 strcmp:
 	push	hl
 	push	de