From 2ddca57f3fc9c79b4d41d46fdc2076a71ca30fc6 Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Tue, 10 Mar 2020 16:02:40 -0400
Subject: [PATCH] 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 | 115 +++++++++++++++++++++++++++++++++++++++++++---
apps/forth/dictionary.txt | 13 ++++++
apps/forth/main.asm | 2 +-
apps/forth/util.asm | 96 +++++++++++++++++++++++++++++---------
apps/lib/util.asm | 2 +-
5 files changed, 198 insertions(+), 30 deletions(-)
diff --git a/apps/forth/dict.asm b/apps/forth/dict.asm
index 99fdea3..cbff0e6 100644
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@@ -282,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
@@ -309,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
@@ -487,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
@@ -571,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
@@ -589,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
@@ -654,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
+
+;
diff --git a/apps/forth/dictionary.txt b/apps/forth/dictionary.txt
index c2562fb..1f38a65 100644
--- a/apps/forth/dictionary.txt
+++ b/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,6 +67,18 @@ 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
diff --git a/apps/forth/main.asm b/apps/forth/main.asm
index 3042579..ab8cb61 100644
--- a/apps/forth/main.asm
+++ b/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
diff --git a/apps/forth/util.asm b/apps/forth/util.asm
index 03282e9..18c7e50 100644
--- a/apps/forth/util.asm
+++ b/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
-; right there on RS' TOS, but no! You have to account for words wrapping the
-; caller. For example, "VARIABLE" calls "CREATE". If you call "VARIABLE foo",
-; if CREATE looks at what follows in RS' TOS, it will only find the "2" in
-; "CREATE 2 ALLOT".
+; name that follows our readLIT caller. We could think that this word is
+; right there on RS' TOS, but not always! You have to account for words wrapping
+; the caller. For example, "VARIABLE" calls "CREATE". If you call
+; "VARIABLE foo", if CREATE looks at what follows in RS' TOS, it will only find
+; the "2" in "CREATE 2 ALLOT".
;
-; Therefore, we actually need to check in RS' *bottom of stack* for our answer.
-; If that atom is a LIT, we're good. We make HL point to it and advance IP to
-; byte following null-termination.
+; In this case, we actually need to check in RS' *bottom of stack* for our
+; answer. If that atom is a LIT, we're good. We make HL point to it and advance
+; 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.
- ld hl, (RS_ADDR)
+;
+; BOS vs TOS: What we cover so far is the "CREATE" and friends cases, where we
+; 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
- pop hl ; <-- lvl 1, our result
+ ex de, hl
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
- ld hl, RS_ADDR
- inc (hl) \ inc (hl)
- pop hl ; <-- lvl 1
+ pop hl ; <-- lvl 2
+ pop de ; <-- lvl 1
+ ; Advance IP by 2
+ 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
+
diff --git a/apps/lib/util.asm b/apps/lib/util.asm
index 386f990..613b860 100644
--- a/apps/lib/util.asm
+++ b/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