mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-26 08:38:06 +11:00
Compare commits
4 Commits
5cadde557c
...
03bd9ee39b
Author | SHA1 | Date | |
---|---|---|---|
|
03bd9ee39b | ||
|
0e8af3cea4 | ||
|
e8a4768304 | ||
|
03e529b762 |
@ -1,5 +1,6 @@
|
||||
; A dictionary entry has this structure:
|
||||
; - 8b name (zero-padded)
|
||||
; - 7b name (zero-padded)
|
||||
; - 1b flags (bit 0: IMMEDIATE)
|
||||
; - 2b prev pointer
|
||||
; - 2b code pointer
|
||||
; - Parameter field (PF)
|
||||
@ -13,11 +14,8 @@
|
||||
nativeWord:
|
||||
jp (iy)
|
||||
|
||||
; Execute a compiled word containing a list of references to other words,
|
||||
; usually ended by a reference to EXIT.
|
||||
; A reference to a word in a compiledWord section is *not* a direct reference,
|
||||
; but a word+CODELINK_OFFSET reference. Therefore, for a code link "link",
|
||||
; (link) is the routine to call.
|
||||
; Execute a list of atoms, which usually ends with EXIT.
|
||||
; IY points to that list.
|
||||
compiledWord:
|
||||
push iy \ pop hl
|
||||
inc hl
|
||||
@ -53,6 +51,69 @@ doesWord:
|
||||
push hl \ pop iy
|
||||
jr compiledWord
|
||||
|
||||
; The IF word checks the stack for zero. If it's non-zero, it does nothing and
|
||||
; allow compiledWord to continue.
|
||||
; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
|
||||
; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
|
||||
; it's a ELSE or THEN, the same thing happens: we resume execution after the
|
||||
; ELSE/THEN. If it's a EXIT, we simply execute it.
|
||||
ifWord:
|
||||
pop hl
|
||||
ld a, h
|
||||
or l
|
||||
jp nz, exit ; non-zero, continue
|
||||
; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
|
||||
|
||||
; If a ELSE word is executed, it means that the preceding IF had a non-zero
|
||||
; condition and continued execution. This means that upon encountering an ELSE,
|
||||
; we must search for a THEN or an EXIT.
|
||||
; To simplify implementation and share code with ifWord, we also match ELSE,
|
||||
; which is only possible in malformed construct. Therefore "IF ELSE ELSE" is
|
||||
; valid and interpreted as "IF ELSE THEN".
|
||||
elseWord:
|
||||
; to save processing, we test EXIT, ELSE and THEN in the order they
|
||||
; appear, address-wise. This way, we don't need to push/pop HL: we can
|
||||
; SUB the difference between the words and check for zeroes.
|
||||
call popRS
|
||||
; We need to save that IP somewhere. Let it be BC
|
||||
ld b, h
|
||||
ld c, l
|
||||
.loop:
|
||||
; Whether there's a match or not, we will resume the operation at IP+2,
|
||||
; which means that we have to increase BC anyways. Let's do it now.
|
||||
inc bc \ inc bc
|
||||
call intoHL
|
||||
or a ; clear carry
|
||||
ld de, EXIT
|
||||
sbc hl, de
|
||||
jp z, exit
|
||||
; Not EXIT, let's continue with ELSE. No carry possible because EXIT
|
||||
; is first word. No need to clear.
|
||||
ld de, ELSE-EXIT
|
||||
sbc hl, de
|
||||
jr c, .nomatch ; A word between EXIT and ELSE. No match.
|
||||
jr z, .match ; We have a ELSE
|
||||
; Let's try with THEN. Again, no carry possible, C cond was handled.
|
||||
ld de, THEN-ELSE
|
||||
sbc hl, de
|
||||
jr z, .match ; We have a THEN
|
||||
.nomatch:
|
||||
; Nothing matched, which means that we need to continue looking.
|
||||
; BC is already IP+2
|
||||
ld h, b
|
||||
ld l, c
|
||||
jr .loop
|
||||
.match:
|
||||
; Matched a ELSE or a THEN, which means we need to continue executing
|
||||
; word from IP+2, which is already in BC.
|
||||
push bc \ pop iy
|
||||
jp compiledWord
|
||||
|
||||
; This word does nothing. It's never going to be executed unless the wordlist
|
||||
; is misconstructed.
|
||||
thenWord:
|
||||
jp exit
|
||||
|
||||
; 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
|
||||
@ -71,11 +132,28 @@ numberWord:
|
||||
NUMBER:
|
||||
.dw numberWord
|
||||
|
||||
; Similarly to numberWord, this is not a real word, but a string literal.
|
||||
; Instead of being followed by a 2 bytes number, it's followed by a
|
||||
; null-terminated string. This is not expected to be called in a regular
|
||||
; context. Only words expecting those literals will look for them. This is why
|
||||
; the litWord triggers abort.
|
||||
litWord:
|
||||
call popRS
|
||||
call intoHL
|
||||
call printstr ; let's print the word before abort.
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp abort
|
||||
.msg:
|
||||
.db "undefined word", 0
|
||||
LIT:
|
||||
.dw litWord
|
||||
|
||||
; ( R:I -- )
|
||||
EXIT:
|
||||
.db "EXIT", 0, 0, 0, 0
|
||||
.db ";"
|
||||
.fill 7
|
||||
.dw 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,
|
||||
@ -88,44 +166,45 @@ exit:
|
||||
call popRS
|
||||
; We have a pointer to a word
|
||||
push hl \ pop iy
|
||||
jr compiledWord
|
||||
jp compiledWord
|
||||
|
||||
; ( R:I -- )
|
||||
QUIT:
|
||||
.db "QUIT", 0, 0, 0, 0
|
||||
.db "QUIT"
|
||||
.fill 4
|
||||
.dw EXIT
|
||||
QUIT:
|
||||
.dw nativeWord
|
||||
quit:
|
||||
ld hl, FLAGS
|
||||
set FLAG_QUITTING, (hl)
|
||||
jr exit
|
||||
jp forthRdLine
|
||||
|
||||
ABORT:
|
||||
.db "ABORT", 0, 0, 0
|
||||
.db "ABORT"
|
||||
.fill 3
|
||||
.dw QUIT
|
||||
ABORT:
|
||||
.dw nativeWord
|
||||
abort:
|
||||
; Reinitialize PS (RS is reinitialized in forthInterpret
|
||||
ld sp, (INITIAL_SP)
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
call printcrlf
|
||||
jr quit
|
||||
.msg:
|
||||
.db " err", 0
|
||||
jp forthRdLine
|
||||
|
||||
BYE:
|
||||
.db "BYE"
|
||||
.fill 5
|
||||
.dw ABORT
|
||||
BYE:
|
||||
.dw nativeWord
|
||||
ld hl, FLAGS
|
||||
set FLAG_ENDPGM, (hl)
|
||||
jp exit
|
||||
; Goodbye Forth! Before we go, let's restore the stack
|
||||
ld sp, (INITIAL_SP)
|
||||
; unwind stack underflow buffer
|
||||
pop af \ pop af \ pop af
|
||||
; success
|
||||
xor a
|
||||
ret
|
||||
|
||||
; ( c -- )
|
||||
EMIT:
|
||||
.db "EMIT", 0, 0, 0, 0
|
||||
.db "EMIT"
|
||||
.fill 4
|
||||
.dw BYE
|
||||
EMIT:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
ld a, l
|
||||
@ -133,13 +212,12 @@ EMIT:
|
||||
jp exit
|
||||
|
||||
; ( addr -- )
|
||||
EXECUTE:
|
||||
.db "EXECUTE", 0
|
||||
.db "EXECUTE"
|
||||
.db 0
|
||||
.dw EMIT
|
||||
EXECUTE:
|
||||
.dw nativeWord
|
||||
pop iy ; Points to word_offset
|
||||
ld de, CODELINK_OFFSET
|
||||
add iy, de
|
||||
pop iy ; is a wordref
|
||||
executeCodeLink:
|
||||
ld l, (iy)
|
||||
ld h, (iy+1)
|
||||
@ -149,46 +227,54 @@ executeCodeLink:
|
||||
; IY points to PFA
|
||||
jp (hl) ; go!
|
||||
|
||||
DEFINE:
|
||||
.db ":"
|
||||
.fill 7
|
||||
.dw EXECUTE
|
||||
DEFINE:
|
||||
.dw nativeWord
|
||||
call entryhead
|
||||
jp nz, quit
|
||||
ld de, compiledWord
|
||||
ld (hl), e
|
||||
inc hl
|
||||
ld (hl), d
|
||||
inc hl
|
||||
push hl \ pop iy
|
||||
; 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.
|
||||
; All we need to do is to know how many bytes to copy. To do so, we
|
||||
; skip compwords until EXIT is reached.
|
||||
ld (HERE), hl ; where we write compwords.
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
.loop:
|
||||
call readword
|
||||
jr nz, .end
|
||||
call .issemicol
|
||||
jr z, .end
|
||||
call compile
|
||||
jp nz, quit
|
||||
call HLPointsEXIT
|
||||
jr z, .loopend
|
||||
call compSkip
|
||||
jr .loop
|
||||
.end:
|
||||
; end chain with EXIT
|
||||
ld hl, EXIT+CODELINK_OFFSET
|
||||
call wrCompHL
|
||||
ld (HERE), iy
|
||||
.loopend:
|
||||
; At this point, HL points to EXIT compword. We'll copy it too.
|
||||
; We'll use LDIR. BC will be RSTOP-OLDRSTOP+2
|
||||
ld e, (ix)
|
||||
ld d, (ix+1)
|
||||
inc hl \ inc hl ; our +2
|
||||
or a ; clear carry
|
||||
sbc hl, de
|
||||
ld b, h
|
||||
ld c, l
|
||||
; BC has proper count
|
||||
ex de, hl ; HL is our source (old RS' TOS)
|
||||
ld de, (HERE) ; and DE is our dest
|
||||
ldir ; go!
|
||||
; HL has our new RS' TOS
|
||||
ld (ix), l
|
||||
ld (ix+1), h
|
||||
ld (HERE), de ; update HERE
|
||||
jp exit
|
||||
.issemicol:
|
||||
ld a, (hl)
|
||||
cp ';'
|
||||
ret nz
|
||||
inc hl
|
||||
ld a, (hl)
|
||||
dec hl
|
||||
or a
|
||||
ret
|
||||
|
||||
DOES:
|
||||
.db "DOES>", 0, 0, 0
|
||||
.db "DOES>"
|
||||
.fill 3
|
||||
.dw DEFINE
|
||||
DOES:
|
||||
.dw nativeWord
|
||||
; We run this when we're in an entry creation context. Many things we
|
||||
; need to do.
|
||||
@ -199,8 +285,6 @@ DOES:
|
||||
; 3. exit. Because we've already popped RS, a regular exit will abort
|
||||
; colon definition, so we're good.
|
||||
ld iy, (CURRENT)
|
||||
ld de, CODELINK_OFFSET
|
||||
add iy, de
|
||||
ld hl, doesWord
|
||||
call wrCompHL
|
||||
inc iy \ inc iy ; cell variable space
|
||||
@ -210,10 +294,10 @@ DOES:
|
||||
jp exit
|
||||
|
||||
; ( -- c )
|
||||
KEY:
|
||||
.db "KEY"
|
||||
.fill 5
|
||||
.dw DOES
|
||||
KEY:
|
||||
.dw nativeWord
|
||||
call stdioGetC
|
||||
ld h, 0
|
||||
@ -221,31 +305,28 @@ KEY:
|
||||
push hl
|
||||
jp exit
|
||||
|
||||
INTERPRET:
|
||||
.db "INTERPRE"
|
||||
.db "INTERPR"
|
||||
.db 0
|
||||
.dw KEY
|
||||
INTERPRET:
|
||||
.dw nativeWord
|
||||
interpret:
|
||||
call readword
|
||||
jp nz, quit
|
||||
ld iy, COMPBUF
|
||||
.loop:
|
||||
call readword
|
||||
jr nz, .end
|
||||
call compile
|
||||
jp nz, .notfound
|
||||
ld hl, EXIT+CODELINK_OFFSET
|
||||
ld (iy), l
|
||||
ld (iy+1), h
|
||||
jr .loop
|
||||
.end:
|
||||
ld hl, QUIT
|
||||
call wrCompHL
|
||||
ld iy, COMPBUF
|
||||
jp compiledWord
|
||||
.notfound:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp quit
|
||||
.msg:
|
||||
.db "not found", 0
|
||||
|
||||
CREATE:
|
||||
.db "CREATE", 0, 0
|
||||
.db "CREATE"
|
||||
.fill 2
|
||||
.dw INTERPRET
|
||||
CREATE:
|
||||
.dw nativeWord
|
||||
call entryhead
|
||||
jp nz, quit
|
||||
@ -257,24 +338,25 @@ CREATE:
|
||||
ld (HERE), hl
|
||||
jp exit
|
||||
|
||||
HERE_: ; Caution: conflicts with actual variable name
|
||||
.db "HERE"
|
||||
.fill 4
|
||||
.dw CREATE
|
||||
HERE_: ; Caution: conflicts with actual variable name
|
||||
.dw sysvarWord
|
||||
.dw HERE
|
||||
|
||||
CURRENT_:
|
||||
.db "CURRENT", 0
|
||||
.db "CURRENT"
|
||||
.db 0
|
||||
.dw HERE_
|
||||
CURRENT_:
|
||||
.dw sysvarWord
|
||||
.dw CURRENT
|
||||
|
||||
; ( n -- )
|
||||
DOT:
|
||||
.db "."
|
||||
.fill 7
|
||||
.dw CURRENT_
|
||||
DOT:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
; We check PS explicitly because it doesn't look nice to spew gibberish
|
||||
@ -286,10 +368,10 @@ DOT:
|
||||
jp exit
|
||||
|
||||
; ( n a -- )
|
||||
STORE:
|
||||
.db "!"
|
||||
.fill 7
|
||||
.dw DOT
|
||||
STORE:
|
||||
.dw nativeWord
|
||||
pop iy
|
||||
pop hl
|
||||
@ -298,10 +380,10 @@ STORE:
|
||||
jp exit
|
||||
|
||||
; ( a -- n )
|
||||
FETCH:
|
||||
.db "@"
|
||||
.fill 7
|
||||
.dw STORE
|
||||
FETCH:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call intoHL
|
||||
@ -309,10 +391,10 @@ FETCH:
|
||||
jp exit
|
||||
|
||||
; ( a b -- b a )
|
||||
SWAP:
|
||||
.db "SWAP"
|
||||
.fill 4
|
||||
.dw FETCH
|
||||
SWAP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
ex (sp), hl
|
||||
@ -320,10 +402,10 @@ SWAP:
|
||||
jp exit
|
||||
|
||||
; ( a -- a a )
|
||||
DUP:
|
||||
.db "DUP"
|
||||
.fill 5
|
||||
.dw SWAP
|
||||
DUP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
push hl
|
||||
@ -331,10 +413,10 @@ DUP:
|
||||
jp exit
|
||||
|
||||
; ( a b -- a b a )
|
||||
OVER:
|
||||
.db "OVER"
|
||||
.fill 4
|
||||
.dw DUP
|
||||
OVER:
|
||||
.dw nativeWord
|
||||
pop hl ; B
|
||||
pop de ; A
|
||||
@ -344,10 +426,10 @@ OVER:
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A + B
|
||||
PLUS:
|
||||
.db "+"
|
||||
.fill 7
|
||||
.dw OVER
|
||||
PLUS:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
pop de
|
||||
@ -356,10 +438,10 @@ PLUS:
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A - B
|
||||
MINUS:
|
||||
.db "-"
|
||||
.fill 7
|
||||
.dw PLUS
|
||||
MINUS:
|
||||
.dw nativeWord
|
||||
pop de ; B
|
||||
pop hl ; A
|
||||
@ -369,10 +451,10 @@ MINUS:
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A * B
|
||||
MULT:
|
||||
.db "*"
|
||||
.fill 7
|
||||
.dw MINUS
|
||||
MULT:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
pop bc
|
||||
@ -381,10 +463,10 @@ MULT:
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A / B
|
||||
DIV:
|
||||
.db "/"
|
||||
.fill 7
|
||||
.dw MULT
|
||||
DIV:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
pop hl
|
||||
@ -392,66 +474,86 @@ DIV:
|
||||
push bc
|
||||
jp exit
|
||||
|
||||
.db "IF"
|
||||
.fill 6
|
||||
.dw DIV
|
||||
IF:
|
||||
.dw ifWord
|
||||
|
||||
.db "ELSE"
|
||||
.fill 4
|
||||
.dw IF
|
||||
ELSE:
|
||||
.dw elseWord
|
||||
|
||||
.db "THEN"
|
||||
.fill 4
|
||||
.dw ELSE
|
||||
THEN:
|
||||
.dw thenWord
|
||||
|
||||
; End of native words
|
||||
|
||||
; ( a -- )
|
||||
; @ .
|
||||
FETCHDOT:
|
||||
.db "?"
|
||||
.fill 7
|
||||
.dw DIV
|
||||
.dw THEN
|
||||
FETCHDOT:
|
||||
.dw compiledWord
|
||||
.dw FETCH+CODELINK_OFFSET
|
||||
.dw DOT+CODELINK_OFFSET
|
||||
.dw EXIT+CODELINK_OFFSET
|
||||
.dw FETCH
|
||||
.dw DOT
|
||||
.dw EXIT
|
||||
|
||||
; ( n a -- )
|
||||
; SWAP OVER @ + SWAP !
|
||||
STOREINC:
|
||||
.db "+!"
|
||||
.fill 6
|
||||
.dw FETCHDOT
|
||||
STOREINC:
|
||||
.dw compiledWord
|
||||
.dw SWAP+CODELINK_OFFSET
|
||||
.dw OVER+CODELINK_OFFSET
|
||||
.dw FETCH+CODELINK_OFFSET
|
||||
.dw PLUS+CODELINK_OFFSET
|
||||
.dw SWAP+CODELINK_OFFSET
|
||||
.dw STORE+CODELINK_OFFSET
|
||||
.dw EXIT+CODELINK_OFFSET
|
||||
.dw SWAP
|
||||
.dw OVER
|
||||
.dw FETCH
|
||||
.dw PLUS
|
||||
.dw SWAP
|
||||
.dw STORE
|
||||
.dw EXIT
|
||||
|
||||
; ( n -- )
|
||||
; HERE +!
|
||||
ALLOT:
|
||||
.db "ALLOT", 0, 0, 0
|
||||
.db "ALLOT"
|
||||
.fill 3
|
||||
.dw STOREINC
|
||||
ALLOT:
|
||||
.dw compiledWord
|
||||
.dw HERE_+CODELINK_OFFSET
|
||||
.dw STOREINC+CODELINK_OFFSET
|
||||
.dw EXIT+CODELINK_OFFSET
|
||||
.dw HERE_
|
||||
.dw STOREINC
|
||||
.dw EXIT
|
||||
|
||||
; CREATE 2 ALLOT
|
||||
VARIABLE:
|
||||
.db "VARIABLE"
|
||||
.db "VARIABL"
|
||||
.db 0
|
||||
.dw ALLOT
|
||||
VARIABLE:
|
||||
.dw compiledWord
|
||||
.dw CREATE+CODELINK_OFFSET
|
||||
.dw CREATE
|
||||
.dw NUMBER
|
||||
.dw 2
|
||||
.dw ALLOT+CODELINK_OFFSET
|
||||
.dw EXIT+CODELINK_OFFSET
|
||||
.dw ALLOT
|
||||
.dw EXIT
|
||||
|
||||
; ( n -- )
|
||||
; CREATE HERE @ ! DOES> @
|
||||
CONSTANT:
|
||||
.db "CONSTANT"
|
||||
.db "CONSTAN"
|
||||
.db 0
|
||||
.dw VARIABLE
|
||||
CONSTANT:
|
||||
.dw compiledWord
|
||||
.dw CREATE+CODELINK_OFFSET
|
||||
.dw HERE_+CODELINK_OFFSET
|
||||
.dw FETCH+CODELINK_OFFSET
|
||||
.dw STORE+CODELINK_OFFSET
|
||||
.dw DOES+CODELINK_OFFSET
|
||||
.dw FETCH+CODELINK_OFFSET
|
||||
.dw EXIT+CODELINK_OFFSET
|
||||
|
||||
.dw CREATE
|
||||
.dw HERE_
|
||||
.dw FETCH
|
||||
.dw STORE
|
||||
.dw DOES
|
||||
.dw FETCH
|
||||
.dw EXIT
|
||||
|
@ -1,23 +1,34 @@
|
||||
Stack notation: "<stack before> -- <stack after>". Rightmost is top of stack
|
||||
(TOS). For example, in "a b -- c d", b is TOS before, d is TOS
|
||||
after. "R:" means that the Return Stack is modified.
|
||||
(TOS). For example, in "a b -- c d", b is TOS before, d is TOS after. "R:" means
|
||||
that the Return Stack is modified.
|
||||
|
||||
DOES>: Used inside a colon definition that itself uses CREATE, DOES> transforms
|
||||
that newly created word into a "does cell", that is, a regular cell (
|
||||
when called, puts the cell's addr on PS), but right after that, it
|
||||
executes words that appear after the DOES>.
|
||||
that newly created word into a "does cell", that is, a regular cell ( when
|
||||
called, puts the cell's addr on PS), but right after that, it executes words
|
||||
that appear after the DOES>.
|
||||
|
||||
"does cells" always allocate 4 bytes (2 for the cell, 2 for the DOES>
|
||||
link) and there is no need for ALLOT in colon definition.
|
||||
"does cells" always allocate 4 bytes (2 for the cell, 2 for the DOES> link) and
|
||||
there is no need for ALLOT in colon definition.
|
||||
|
||||
At compile time, colon definition stops processing words when reaching
|
||||
the DOES>.
|
||||
At compile time, colon definition stops processing words when reaching the
|
||||
DOES>.
|
||||
|
||||
Example: ": CONSTANT CREATE HERE @ ! DOES> @ ;"
|
||||
|
||||
Word references (wordref): When we say we have a "word reference", it's a
|
||||
pointer to a words *code link*. For example, the label "PLUS:" in this unit is a
|
||||
word reference. Why not refer to the beginning of the word struct? Because we
|
||||
actually seldom refer to the name and prev link, except during compilation, so
|
||||
defining "word reference" this way makes the code easier to understand.
|
||||
|
||||
Atom: A word of the type compiledWord contains, in its PF, a list of what we
|
||||
call "atoms". Those atoms are most of the time word references, but they can
|
||||
also be references to NUMBER and LIT.
|
||||
|
||||
*** Native Words ***
|
||||
|
||||
: x ... ; -- Define a new word
|
||||
: x ... -- Define a new word
|
||||
; R:I -- Exit a colon definition
|
||||
. n -- Print n in its decimal form
|
||||
@ a -- n Set n to value at address a
|
||||
! n a -- Store n in address a
|
||||
@ -26,18 +37,22 @@ DOES>: Used inside a colon definition that itself uses CREATE, DOES> transforms
|
||||
* a b -- c a * b -> c
|
||||
/ a b -- c a / b -> c
|
||||
CREATE x -- Create cell named x. Doesn't allocate a PF.
|
||||
CURRENT -- n Set n to wordref of last added entry.
|
||||
DOES> -- See description at top of file
|
||||
DUP a -- a a
|
||||
ELSE -- Branch to THEN
|
||||
EMIT c -- Spit char c to stdout
|
||||
EXECUTE a -- Execute word at addr a
|
||||
EXIT R:I -- Exit a colon definition
|
||||
EXECUTE a -- Execute wordref at addr a
|
||||
HERE -- a Push HERE's address
|
||||
IF n -- Branch to ELSE or THEN if n is zero
|
||||
QUIT R:drop -- Return to interpreter promp immediately
|
||||
KEY -- c Get char c from stdin
|
||||
INTERPRET -- Get a line from stdin, compile it in tmp memory,
|
||||
then execute the compiled contents.
|
||||
OVER a b -- a b a
|
||||
SWAP a b -- b a
|
||||
THEN -- Does nothing. Serves as a branching merker for IF
|
||||
and ELSE.
|
||||
|
||||
*** Core-but-Forth Words ***
|
||||
|
||||
|
@ -4,50 +4,20 @@
|
||||
; Number of bytes we keep as a padding between HERE and the scratchpad
|
||||
.equ PADDING 0x20
|
||||
; Max length of dict entry names
|
||||
.equ NAMELEN 8
|
||||
.equ NAMELEN 7
|
||||
; Offset of the code link relative to the beginning of the word
|
||||
.equ CODELINK_OFFSET 10
|
||||
; When set, the interpreter should abort parsing of current line and return to
|
||||
; prompt.
|
||||
.equ FLAG_QUITTING 0
|
||||
; When set, the interpreter should quit
|
||||
.equ FLAG_ENDPGM 1
|
||||
.equ CODELINK_OFFSET NAMELEN+3
|
||||
|
||||
; *** Variables ***
|
||||
.equ INITIAL_SP FORTH_RAMSTART
|
||||
.equ CURRENT @+2
|
||||
.equ HERE @+2
|
||||
.equ INPUTPOS @+2
|
||||
.equ FLAGS @+2
|
||||
; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
|
||||
.equ COMPBUF @+1
|
||||
.equ COMPBUF @+2
|
||||
.equ FORTH_RAMEND @+0x40
|
||||
|
||||
; *** Code ***
|
||||
MAIN:
|
||||
.dw compiledWord
|
||||
.dw INTERPRET+CODELINK_OFFSET
|
||||
.dw CHKEND
|
||||
|
||||
; If FLAG_ENDPGM is set, stop the program, else, tweak the RS so that we loop.
|
||||
CHKEND:
|
||||
.dw nativeWord
|
||||
ld hl, FLAGS
|
||||
bit FLAG_ENDPGM, (hl)
|
||||
jr nz, .endpgm
|
||||
; not quitting program, are we supposed to continue parsing line?
|
||||
ld hl, FLAGS
|
||||
bit FLAG_QUITTING, (hl)
|
||||
jr nz, forthRdLine
|
||||
; Not quitting line either.
|
||||
jr forthInterpret
|
||||
.endpgm:
|
||||
ld sp, (INITIAL_SP)
|
||||
; restore stack
|
||||
pop af \ pop af \ pop af
|
||||
xor a
|
||||
ret
|
||||
|
||||
forthMain:
|
||||
; STACK OVERFLOW PROTECTION:
|
||||
; To avoid having to check for stack underflow after each pop operation
|
||||
@ -62,16 +32,14 @@ forthMain:
|
||||
ld hl, FORTH_RAMEND
|
||||
ld (HERE), hl
|
||||
forthRdLine:
|
||||
xor a
|
||||
ld (FLAGS), a
|
||||
ld hl, msgOk
|
||||
call printstr
|
||||
call printcrlf
|
||||
call stdioReadLine
|
||||
ld (INPUTPOS), hl
|
||||
forthInterpret:
|
||||
ld ix, RS_ADDR
|
||||
ld iy, MAIN
|
||||
ld ix, RS_ADDR-2 ; -2 because we inc-before-push
|
||||
ld iy, INTERPRET
|
||||
jp executeCodeLink
|
||||
msgOk:
|
||||
.db " ok", 0
|
||||
|
@ -3,25 +3,26 @@
|
||||
; PS is the most frequently used. However, this causes a problem with routine
|
||||
; calls: because in Forth, the stack isn't balanced within each call, our return
|
||||
; offset, when placed by a CALL, messes everything up. This is one of the
|
||||
; reasons why we need stack management routines below.
|
||||
; reasons why we need stack management routines below. IX always points to RS'
|
||||
; Top Of Stack (TOS)
|
||||
;
|
||||
; This return stack contain "Interpreter pointers", that is a pointer to the
|
||||
; address of a word, as seen in a compiled list of words.
|
||||
|
||||
; Push value HL to RS
|
||||
pushRS:
|
||||
inc ix
|
||||
inc ix
|
||||
ld (ix), l
|
||||
inc ix
|
||||
ld (ix), h
|
||||
inc ix
|
||||
ld (ix+1), h
|
||||
ret
|
||||
|
||||
; Pop RS' TOS to HL
|
||||
popRS:
|
||||
dec ix
|
||||
ld h, (ix)
|
||||
dec ix
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
dec ix
|
||||
dec ix
|
||||
ret
|
||||
|
||||
; Verifies that SP is within bounds. If it's not, call ABORT
|
||||
|
@ -43,14 +43,136 @@ readword:
|
||||
inc a ; unset Z
|
||||
ret
|
||||
|
||||
; For DE pointing to a dict entry, set DE to point to the previous entry.
|
||||
; Sets Z if (HL) == E and (HL+1) == D
|
||||
HLPointsDE:
|
||||
ld a, (hl)
|
||||
cp e
|
||||
ret nz ; no
|
||||
inc hl
|
||||
ld a, (hl)
|
||||
dec hl
|
||||
cp d ; Z has our answer
|
||||
ret
|
||||
|
||||
|
||||
HLPointsNUMBER:
|
||||
push de
|
||||
ld de, NUMBER
|
||||
call HLPointsDE
|
||||
pop de
|
||||
ret
|
||||
|
||||
HLPointsLIT:
|
||||
push de
|
||||
ld de, LIT
|
||||
call HLPointsDE
|
||||
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.
|
||||
compSkip:
|
||||
call HLPointsNUMBER
|
||||
jr z, .isNum
|
||||
call HLPointsLIT
|
||||
jr nz, .isWord
|
||||
; We have a literal
|
||||
inc hl \ inc hl
|
||||
call strskip
|
||||
inc hl ; byte after word termination
|
||||
ret
|
||||
.isNum:
|
||||
; skip by 4
|
||||
inc hl \ inc hl
|
||||
; continue to isWord
|
||||
.isWord:
|
||||
; skip by 2
|
||||
inc hl \ inc hl
|
||||
ret
|
||||
|
||||
; 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".
|
||||
;
|
||||
; 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.
|
||||
;
|
||||
; 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
|
||||
; word. So in that case, we'll copy the word's name on the pad (it might not be
|
||||
; null-terminated) and set HL to point to it.
|
||||
; How do we know that our reference is a word reference (it could be, for
|
||||
; example, a NUMBER reference)? We check that its address is more than QUIT, the
|
||||
; 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)
|
||||
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
|
||||
call strskip
|
||||
inc hl ; byte after word termination
|
||||
ld (RS_ADDR), 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
|
||||
; Not a number, then it's a word. Copy word to pad and point to it.
|
||||
call intoHL
|
||||
or a ; clear carry
|
||||
ld de, CODELINK_OFFSET
|
||||
sbc hl, de
|
||||
; That's our return value
|
||||
push hl ; --> lvl 1
|
||||
; HL now points to word offset, let'd copy it to pad
|
||||
ex de, hl
|
||||
call pad
|
||||
ex de, hl
|
||||
ld bc, NAMELEN
|
||||
ldir
|
||||
; null-terminate
|
||||
xor a
|
||||
ld (de), a
|
||||
; Advance RS' BOS by 2
|
||||
ld hl, RS_ADDR
|
||||
inc (hl) \ inc (hl)
|
||||
pop hl ; <-- lvl 1
|
||||
ret
|
||||
.notWord:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp abort
|
||||
.msg:
|
||||
.db "word expected", 0
|
||||
|
||||
; 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:
|
||||
push hl ; --> lvl 1
|
||||
ld hl, NAMELEN ; prev field offset
|
||||
add hl, de
|
||||
ex de, hl
|
||||
pop hl ; <-- lvl 1
|
||||
dec de \ dec de ; prev field
|
||||
call intoDE
|
||||
; DE points to prev. Is it zero?
|
||||
xor a
|
||||
@ -63,15 +185,28 @@ prev:
|
||||
; point to that entry.
|
||||
; Z if found, NZ if not.
|
||||
find:
|
||||
push hl
|
||||
push bc
|
||||
ld de, (CURRENT)
|
||||
ld bc, CODELINK_OFFSET
|
||||
.inner:
|
||||
; DE is a wordref, let's go to beginning of struct
|
||||
push de ; --> lvl 1
|
||||
or a ; clear carry
|
||||
ex de, hl
|
||||
sbc hl, bc
|
||||
ex de, hl ; We're good, DE points to word name
|
||||
ld a, NAMELEN
|
||||
call strncmp
|
||||
ret z ; found
|
||||
pop de ; <-- lvl 1, return to wordref
|
||||
jr z, .end ; found
|
||||
call prev
|
||||
jr nz, .inner
|
||||
; Z set? end of dict unset Z
|
||||
inc a
|
||||
.end:
|
||||
pop bc
|
||||
pop hl
|
||||
ret
|
||||
|
||||
; Write compiled data from HL into IY, advancing IY at the same time.
|
||||
@ -84,49 +219,58 @@ wrCompHL:
|
||||
|
||||
; Compile word string at (HL) and write down its compiled version in IY,
|
||||
; advancing IY to the byte next to the last written byte.
|
||||
; Set Z on success, unset on failure.
|
||||
compile:
|
||||
call find
|
||||
jr nz, .maybeNum
|
||||
ret nz
|
||||
; DE is a word offset, we need a code link
|
||||
ld hl, CODELINK_OFFSET
|
||||
add hl, de
|
||||
xor a ; set Z
|
||||
ex de, hl
|
||||
jr wrCompHL
|
||||
.maybeNum:
|
||||
push hl ; --> lvl 1. save string addr
|
||||
call parseLiteral
|
||||
ret nz
|
||||
jr nz, .undef
|
||||
pop hl ; <-- lvl 1
|
||||
; a valid number!
|
||||
ld hl, NUMBER
|
||||
call wrCompHL
|
||||
ex de, hl ; number in HL
|
||||
jr wrCompHL
|
||||
ret z
|
||||
; unknown name
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp abort
|
||||
.msg:
|
||||
.db "unknown name", 0
|
||||
.undef:
|
||||
; 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
|
||||
; called, triggering an abort.
|
||||
ld hl, LIT
|
||||
call wrCompHL
|
||||
pop hl ; <-- lvl 1. recall string addr
|
||||
.writeLit:
|
||||
ld a, (hl)
|
||||
ld (iy), a
|
||||
inc hl
|
||||
inc iy
|
||||
or a
|
||||
jr nz, .writeLit
|
||||
ret
|
||||
|
||||
|
||||
; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
|
||||
; HL points to new (HERE)
|
||||
; Set Z if name could be read, NZ if not
|
||||
entryhead:
|
||||
call readword
|
||||
ret nz
|
||||
call readCompWord
|
||||
ld de, (HERE)
|
||||
call strcpy
|
||||
ex de, hl ; (HERE) now in HL
|
||||
ld de, (CURRENT)
|
||||
ld (CURRENT), hl
|
||||
ld a, NAMELEN
|
||||
call addHL
|
||||
xor a ; IMMED
|
||||
ld (hl), a
|
||||
inc hl
|
||||
ld (hl), e
|
||||
inc hl
|
||||
ld (hl), d
|
||||
inc hl
|
||||
ld (CURRENT), hl
|
||||
ld (HERE), hl
|
||||
xor a ; set Z
|
||||
ret
|
||||
|
Loading…
Reference in New Issue
Block a user