mirror of
https://github.com/hsoft/collapseos.git
synced 2024-12-26 05:28:05 +11:00
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.
This commit is contained in:
parent
aac0a57a68
commit
2ddca57f3f
@ -282,9 +282,7 @@ DEFINE:
|
|||||||
; is lit
|
; is lit
|
||||||
ldi
|
ldi
|
||||||
ldi
|
ldi
|
||||||
inc hl \ inc hl
|
|
||||||
call strcpyM
|
call strcpyM
|
||||||
inc hl ; byte after word termination
|
|
||||||
jr .loop
|
jr .loop
|
||||||
.notLIT:
|
.notLIT:
|
||||||
; it's a word
|
; it's a word
|
||||||
@ -309,7 +307,7 @@ DEFINE:
|
|||||||
; a good old regular word. We have 2 bytes to copy. But before we do,
|
; 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
|
; let's check whether it's an EXIT. LDI doesn't affect Z, so we can
|
||||||
; make our jump later.
|
; make our jump later.
|
||||||
call HLPointsEXIT
|
call HLPointsEXITQUIT
|
||||||
ldi
|
ldi
|
||||||
ldi
|
ldi
|
||||||
jr nz, .loop
|
jr nz, .loop
|
||||||
@ -487,10 +485,20 @@ FETCH:
|
|||||||
push hl
|
push hl
|
||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
|
; ( -- a )
|
||||||
|
.db "LIT@"
|
||||||
|
.fill 4
|
||||||
|
.dw FETCH
|
||||||
|
LITFETCH:
|
||||||
|
.dw nativeWord
|
||||||
|
call readLITTOS
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
; ( a b -- b a )
|
; ( a b -- b a )
|
||||||
.db "SWAP"
|
.db "SWAP"
|
||||||
.fill 4
|
.fill 4
|
||||||
.dw FETCH
|
.dw LITFETCH
|
||||||
SWAP:
|
SWAP:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop hl
|
pop hl
|
||||||
@ -571,9 +579,36 @@ DIV:
|
|||||||
push bc
|
push bc
|
||||||
jp exit
|
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"
|
.db "IF"
|
||||||
.fill 6
|
.fill 6
|
||||||
.dw DIV
|
.dw CMP
|
||||||
IF:
|
IF:
|
||||||
.dw ifWord
|
.dw ifWord
|
||||||
|
|
||||||
@ -589,13 +624,25 @@ ELSE:
|
|||||||
THEN:
|
THEN:
|
||||||
.dw thenWord
|
.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
|
; End of native words
|
||||||
|
|
||||||
; ( a -- )
|
; ( a -- )
|
||||||
; @ .
|
; @ .
|
||||||
.db "?"
|
.db "?"
|
||||||
.fill 7
|
.fill 7
|
||||||
.dw THEN
|
.dw RECURSE
|
||||||
FETCHDOT:
|
FETCHDOT:
|
||||||
.dw compiledWord
|
.dw compiledWord
|
||||||
.dw FETCH
|
.dw FETCH
|
||||||
@ -654,3 +701,59 @@ CONSTANT:
|
|||||||
.dw DOES
|
.dw DOES
|
||||||
.dw FETCH
|
.dw FETCH
|
||||||
.dw EXIT
|
.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
|
||||||
|
|
||||||
|
;
|
||||||
|
@ -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,
|
INTERPRET -- Get a line from stdin, compile it in tmp memory,
|
||||||
then execute the compiled contents.
|
then execute the compiled contents.
|
||||||
QUIT R:drop -- Return to interpreter promp immediately
|
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
|
THEN -- Does nothing. Serves as a branching merker for IF
|
||||||
and ELSE.
|
and ELSE.
|
||||||
|
|
||||||
@ -66,6 +67,18 @@ HERE -- a Push HERE's address
|
|||||||
* a b -- c a * b -> c
|
* a b -- c a * b -> c
|
||||||
/ 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 ***
|
*** I/O ***
|
||||||
. n -- Print n in its decimal form
|
. n -- Print n in its decimal form
|
||||||
EMIT c -- Spit char c to stdout
|
EMIT c -- Spit char c to stdout
|
||||||
|
@ -27,7 +27,7 @@ forthMain:
|
|||||||
; we check for stack underflow.
|
; we check for stack underflow.
|
||||||
push af \ push af \ push af
|
push af \ push af \ push af
|
||||||
ld (INITIAL_SP), sp
|
ld (INITIAL_SP), sp
|
||||||
ld hl, CONSTANT ; last entry in hardcoded dict
|
ld hl, LATEST
|
||||||
ld (CURRENT), hl
|
ld (CURRENT), hl
|
||||||
ld hl, FORTH_RAMEND
|
ld hl, FORTH_RAMEND
|
||||||
ld (HERE), hl
|
ld (HERE), hl
|
||||||
|
@ -69,10 +69,14 @@ HLPointsLIT:
|
|||||||
pop de
|
pop de
|
||||||
ret
|
ret
|
||||||
|
|
||||||
HLPointsEXIT:
|
HLPointsEXITQUIT:
|
||||||
push de
|
push de
|
||||||
ld de, EXIT
|
ld de, EXIT
|
||||||
call HLPointsDE
|
call HLPointsDE
|
||||||
|
jr z, .end
|
||||||
|
ld de, QUIT
|
||||||
|
call HLPointsDE
|
||||||
|
.end:
|
||||||
pop de
|
pop de
|
||||||
ret
|
ret
|
||||||
|
|
||||||
@ -98,21 +102,22 @@ compSkip:
|
|||||||
inc hl \ inc hl
|
inc hl \ inc hl
|
||||||
ret
|
ret
|
||||||
|
|
||||||
|
; ***readLIT***
|
||||||
; The goal of this routine is to read a string literal following the currently
|
; 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
|
; executed words. For example, CREATE and DEFINE need this. Things are a little
|
||||||
; twisted, so bear with me while I explain how it works.
|
; 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
|
; 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
|
; 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
|
; 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
|
; 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
|
; second word in our dict. We don't accept EXIT because it's the termination
|
||||||
; word. Yeah, it means that ";" can't be overridden...
|
; word. Yeah, it means that ";" can't be overridden...
|
||||||
; If name can't be read, we abort
|
; 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
|
call HLPointsLIT
|
||||||
jr nz, .notLIT
|
jr nz, .notLIT
|
||||||
; RS BOS is a LIT, make HL point to string, then skip this RS compword.
|
; 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
|
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
|
call strskip
|
||||||
inc hl ; byte after word termination
|
inc hl ; byte after word termination
|
||||||
ld (RS_ADDR), hl
|
ex de, hl
|
||||||
pop hl ; <-- lvl 1, our result
|
|
||||||
ret
|
ret
|
||||||
.notLIT:
|
.notLIT:
|
||||||
; Alright, not a literal, but is it a word? If it's not a number, then
|
; Alright, not a literal, but is it a word? If it's not a number, then
|
||||||
; it's a word.
|
; it's a word.
|
||||||
call HLPointsNUMBER
|
call HLPointsNUMBER
|
||||||
jr z, .notWord
|
jr z, .notWord
|
||||||
|
call HLPointsEXITQUIT
|
||||||
|
jr z, .notWord
|
||||||
; Not a number, then it's a word. Copy word to pad and point to it.
|
; 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
|
call intoHL
|
||||||
or a ; clear carry
|
or a ; clear carry
|
||||||
ld de, CODELINK_OFFSET
|
ld de, CODELINK_OFFSET
|
||||||
sbc hl, de
|
sbc hl, de
|
||||||
; That's our return value
|
; 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
|
; HL now points to word offset, let'd copy it to pad
|
||||||
ex de, hl
|
ex de, hl
|
||||||
call pad
|
call pad
|
||||||
@ -157,10 +179,10 @@ readCompWord:
|
|||||||
; null-terminate
|
; null-terminate
|
||||||
xor a
|
xor a
|
||||||
ld (de), 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
|
ret
|
||||||
.notWord:
|
.notWord:
|
||||||
ld hl, .msg
|
ld hl, .msg
|
||||||
@ -169,6 +191,24 @@ readCompWord:
|
|||||||
.msg:
|
.msg:
|
||||||
.db "word expected", 0
|
.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.
|
; For DE being a wordref, move DE to the previous wordref.
|
||||||
; Z is set if DE point to 0 (no entry). NZ if not.
|
; Z is set if DE point to 0 (no entry). NZ if not.
|
||||||
prev:
|
prev:
|
||||||
@ -238,7 +278,7 @@ compile:
|
|||||||
; When encountering an undefined word during compilation, we spit a
|
; When encountering an undefined word during compilation, we spit a
|
||||||
; reference to litWord, followed by the null-terminated word.
|
; reference to litWord, followed by the null-terminated word.
|
||||||
; This way, if a preceding word expect a string literal, it will read it
|
; 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.
|
; called, triggering an abort.
|
||||||
ld hl, LIT
|
ld hl, LIT
|
||||||
call wrCompHL
|
call wrCompHL
|
||||||
@ -256,7 +296,7 @@ compile:
|
|||||||
; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
|
; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
|
||||||
; HL points to new (HERE)
|
; HL points to new (HERE)
|
||||||
entryhead:
|
entryhead:
|
||||||
call readCompWord
|
call readLITBOS
|
||||||
ld de, (HERE)
|
ld de, (HERE)
|
||||||
call strcpy
|
call strcpy
|
||||||
ex de, hl ; (HERE) now in HL
|
ex de, hl ; (HERE) now in HL
|
||||||
@ -291,3 +331,15 @@ HLPointsIMMED:
|
|||||||
inc hl
|
inc hl
|
||||||
pop hl
|
pop hl
|
||||||
ret
|
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
|
||||||
|
|
||||||
|
@ -52,7 +52,7 @@ strcpy:
|
|||||||
ret
|
ret
|
||||||
|
|
||||||
; Compares strings pointed to by HL and DE until one of them hits its null char.
|
; 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:
|
strcmp:
|
||||||
push hl
|
push hl
|
||||||
push de
|
push de
|
||||||
|
Loading…
Reference in New Issue
Block a user