mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 18:20:55 +11:00
Compare commits
11 Commits
97dcad9b15
...
5cadde557c
Author | SHA1 | Date | |
---|---|---|---|
|
5cadde557c | ||
|
989d8bbabf | ||
|
53024d88f5 | ||
|
f0cf10ab7c | ||
|
580214426a | ||
|
ad2aca4620 | ||
|
30f188b984 | ||
|
e7cd3182d0 | ||
|
6f9d28b325 | ||
|
391ddb9984 | ||
|
49228e418c |
7
apps/forth/README.md
Normal file
7
apps/forth/README.md
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
# Forth
|
||||||
|
|
||||||
|
**WIP** A Forth interpreter. Far from complete, but you can do stuff like
|
||||||
|
|
||||||
|
KEY EMIT KEY EMIT
|
||||||
|
|
||||||
|
See dictionary.txt for a word reference.
|
457
apps/forth/dict.asm
Normal file
457
apps/forth/dict.asm
Normal file
@ -0,0 +1,457 @@
|
|||||||
|
; A dictionary entry has this structure:
|
||||||
|
; - 8b name (zero-padded)
|
||||||
|
; - 2b prev pointer
|
||||||
|
; - 2b code pointer
|
||||||
|
; - Parameter field (PF)
|
||||||
|
;
|
||||||
|
; 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 the top of the Return Stack. They will usually do so with
|
||||||
|
; "jp exit".
|
||||||
|
|
||||||
|
; Execute a word containing native code at its PF address (PFA)
|
||||||
|
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.
|
||||||
|
compiledWord:
|
||||||
|
push iy \ pop hl
|
||||||
|
inc hl
|
||||||
|
inc hl
|
||||||
|
; HL points to next Interpreter pointer.
|
||||||
|
call pushRS
|
||||||
|
ld l, (iy)
|
||||||
|
ld h, (iy+1)
|
||||||
|
push hl \ pop iy
|
||||||
|
; IY points to code link
|
||||||
|
jp executeCodeLink
|
||||||
|
|
||||||
|
; Pushes the PFA directly
|
||||||
|
cellWord:
|
||||||
|
push iy
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; Pushes the address in the first word of the PF
|
||||||
|
sysvarWord:
|
||||||
|
ld l, (iy)
|
||||||
|
ld h, (iy+1)
|
||||||
|
push hl
|
||||||
|
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>.
|
||||||
|
; Therefore, what we need to do push the cell addr like a regular cell, then
|
||||||
|
; follow the link from the PFA, and then continue as a regular compiledWord.
|
||||||
|
doesWord:
|
||||||
|
push iy ; like a regular cell
|
||||||
|
ld l, (iy+2)
|
||||||
|
ld h, (iy+3)
|
||||||
|
push hl \ pop iy
|
||||||
|
jr compiledWord
|
||||||
|
|
||||||
|
; 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 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:
|
||||||
|
call popRS
|
||||||
|
ld e, (hl)
|
||||||
|
inc hl
|
||||||
|
ld d, (hl)
|
||||||
|
inc hl
|
||||||
|
call pushRS
|
||||||
|
push de
|
||||||
|
jp exit
|
||||||
|
NUMBER:
|
||||||
|
.dw numberWord
|
||||||
|
|
||||||
|
|
||||||
|
; ( R:I -- )
|
||||||
|
EXIT:
|
||||||
|
.db "EXIT", 0, 0, 0, 0
|
||||||
|
.dw 0
|
||||||
|
.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
|
||||||
|
exit:
|
||||||
|
; 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
|
||||||
|
jr compiledWord
|
||||||
|
|
||||||
|
; ( R:I -- )
|
||||||
|
QUIT:
|
||||||
|
.db "QUIT", 0, 0, 0, 0
|
||||||
|
.dw EXIT
|
||||||
|
.dw nativeWord
|
||||||
|
quit:
|
||||||
|
ld hl, FLAGS
|
||||||
|
set FLAG_QUITTING, (hl)
|
||||||
|
jr exit
|
||||||
|
|
||||||
|
ABORT:
|
||||||
|
.db "ABORT", 0, 0, 0
|
||||||
|
.dw QUIT
|
||||||
|
.dw nativeWord
|
||||||
|
abort:
|
||||||
|
ld sp, (INITIAL_SP)
|
||||||
|
ld hl, .msg
|
||||||
|
call printstr
|
||||||
|
call printcrlf
|
||||||
|
jr quit
|
||||||
|
.msg:
|
||||||
|
.db " err", 0
|
||||||
|
|
||||||
|
BYE:
|
||||||
|
.db "BYE"
|
||||||
|
.fill 5
|
||||||
|
.dw ABORT
|
||||||
|
.dw nativeWord
|
||||||
|
ld hl, FLAGS
|
||||||
|
set FLAG_ENDPGM, (hl)
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( c -- )
|
||||||
|
EMIT:
|
||||||
|
.db "EMIT", 0, 0, 0, 0
|
||||||
|
.dw BYE
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
ld a, l
|
||||||
|
call stdioPutC
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( addr -- )
|
||||||
|
EXECUTE:
|
||||||
|
.db "EXECUTE", 0
|
||||||
|
.dw EMIT
|
||||||
|
.dw nativeWord
|
||||||
|
pop iy ; Points to word_offset
|
||||||
|
ld de, CODELINK_OFFSET
|
||||||
|
add iy, de
|
||||||
|
executeCodeLink:
|
||||||
|
ld l, (iy)
|
||||||
|
ld h, (iy+1)
|
||||||
|
; HL points to code pointer
|
||||||
|
inc iy
|
||||||
|
inc iy
|
||||||
|
; IY points to PFA
|
||||||
|
jp (hl) ; go!
|
||||||
|
|
||||||
|
DEFINE:
|
||||||
|
.db ":"
|
||||||
|
.fill 7
|
||||||
|
.dw EXECUTE
|
||||||
|
.dw nativeWord
|
||||||
|
call entryhead
|
||||||
|
jp nz, quit
|
||||||
|
ld de, compiledWord
|
||||||
|
ld (hl), e
|
||||||
|
inc hl
|
||||||
|
ld (hl), d
|
||||||
|
inc hl
|
||||||
|
push hl \ pop iy
|
||||||
|
.loop:
|
||||||
|
call readword
|
||||||
|
jr nz, .end
|
||||||
|
call .issemicol
|
||||||
|
jr z, .end
|
||||||
|
call compile
|
||||||
|
jp nz, quit
|
||||||
|
jr .loop
|
||||||
|
.end:
|
||||||
|
; end chain with EXIT
|
||||||
|
ld hl, EXIT+CODELINK_OFFSET
|
||||||
|
call wrCompHL
|
||||||
|
ld (HERE), iy
|
||||||
|
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
|
||||||
|
.dw DEFINE
|
||||||
|
.dw nativeWord
|
||||||
|
; We run this when we're in an entry creation context. Many things we
|
||||||
|
; need to do.
|
||||||
|
; 1. Change the code link to doesWord
|
||||||
|
; 2. Leave 2 bytes for regular cell variable.
|
||||||
|
; 3. Get the Interpreter pointer from the stack and write this down to
|
||||||
|
; 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 de, CODELINK_OFFSET
|
||||||
|
add iy, de
|
||||||
|
ld hl, doesWord
|
||||||
|
call wrCompHL
|
||||||
|
inc iy \ inc iy ; cell variable space
|
||||||
|
call popRS
|
||||||
|
call wrCompHL
|
||||||
|
ld (HERE), iy
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( -- c )
|
||||||
|
KEY:
|
||||||
|
.db "KEY"
|
||||||
|
.fill 5
|
||||||
|
.dw DOES
|
||||||
|
.dw nativeWord
|
||||||
|
call stdioGetC
|
||||||
|
ld h, 0
|
||||||
|
ld l, a
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
INTERPRET:
|
||||||
|
.db "INTERPRE"
|
||||||
|
.dw KEY
|
||||||
|
.dw nativeWord
|
||||||
|
interpret:
|
||||||
|
call readword
|
||||||
|
jp nz, quit
|
||||||
|
ld iy, COMPBUF
|
||||||
|
call compile
|
||||||
|
jp nz, .notfound
|
||||||
|
ld hl, EXIT+CODELINK_OFFSET
|
||||||
|
ld (iy), l
|
||||||
|
ld (iy+1), h
|
||||||
|
ld iy, COMPBUF
|
||||||
|
jp compiledWord
|
||||||
|
.notfound:
|
||||||
|
ld hl, .msg
|
||||||
|
call printstr
|
||||||
|
jp quit
|
||||||
|
.msg:
|
||||||
|
.db "not found", 0
|
||||||
|
|
||||||
|
CREATE:
|
||||||
|
.db "CREATE", 0, 0
|
||||||
|
.dw INTERPRET
|
||||||
|
.dw nativeWord
|
||||||
|
call entryhead
|
||||||
|
jp nz, quit
|
||||||
|
ld de, cellWord
|
||||||
|
ld (hl), e
|
||||||
|
inc hl
|
||||||
|
ld (hl), d
|
||||||
|
inc hl
|
||||||
|
ld (HERE), hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
HERE_: ; Caution: conflicts with actual variable name
|
||||||
|
.db "HERE"
|
||||||
|
.fill 4
|
||||||
|
.dw CREATE
|
||||||
|
.dw sysvarWord
|
||||||
|
.dw HERE
|
||||||
|
|
||||||
|
CURRENT_:
|
||||||
|
.db "CURRENT", 0
|
||||||
|
.dw HERE_
|
||||||
|
.dw sysvarWord
|
||||||
|
.dw CURRENT
|
||||||
|
|
||||||
|
; ( n -- )
|
||||||
|
DOT:
|
||||||
|
.db "."
|
||||||
|
.fill 7
|
||||||
|
.dw CURRENT_
|
||||||
|
.dw nativeWord
|
||||||
|
pop de
|
||||||
|
; We check PS explicitly because it doesn't look nice to spew gibberish
|
||||||
|
; before aborting the stack underflow.
|
||||||
|
call chkPS
|
||||||
|
call pad
|
||||||
|
call fmtDecimalS
|
||||||
|
call printstr
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( n a -- )
|
||||||
|
STORE:
|
||||||
|
.db "!"
|
||||||
|
.fill 7
|
||||||
|
.dw DOT
|
||||||
|
.dw nativeWord
|
||||||
|
pop iy
|
||||||
|
pop hl
|
||||||
|
ld (iy), l
|
||||||
|
ld (iy+1), h
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a -- n )
|
||||||
|
FETCH:
|
||||||
|
.db "@"
|
||||||
|
.fill 7
|
||||||
|
.dw STORE
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
call intoHL
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- b a )
|
||||||
|
SWAP:
|
||||||
|
.db "SWAP"
|
||||||
|
.fill 4
|
||||||
|
.dw FETCH
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
ex (sp), hl
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a -- a a )
|
||||||
|
DUP:
|
||||||
|
.db "DUP"
|
||||||
|
.fill 5
|
||||||
|
.dw SWAP
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
push hl
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- a b a )
|
||||||
|
OVER:
|
||||||
|
.db "OVER"
|
||||||
|
.fill 4
|
||||||
|
.dw DUP
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl ; B
|
||||||
|
pop de ; A
|
||||||
|
push de
|
||||||
|
push hl
|
||||||
|
push de
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- c ) A + B
|
||||||
|
PLUS:
|
||||||
|
.db "+"
|
||||||
|
.fill 7
|
||||||
|
.dw OVER
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
pop de
|
||||||
|
add hl, de
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- c ) A - B
|
||||||
|
MINUS:
|
||||||
|
.db "-"
|
||||||
|
.fill 7
|
||||||
|
.dw PLUS
|
||||||
|
.dw nativeWord
|
||||||
|
pop de ; B
|
||||||
|
pop hl ; A
|
||||||
|
or a ; reset carry
|
||||||
|
sbc hl, de
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- c ) A * B
|
||||||
|
MULT:
|
||||||
|
.db "*"
|
||||||
|
.fill 7
|
||||||
|
.dw MINUS
|
||||||
|
.dw nativeWord
|
||||||
|
pop de
|
||||||
|
pop bc
|
||||||
|
call multDEBC
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a b -- c ) A / B
|
||||||
|
DIV:
|
||||||
|
.db "/"
|
||||||
|
.fill 7
|
||||||
|
.dw MULT
|
||||||
|
.dw nativeWord
|
||||||
|
pop de
|
||||||
|
pop hl
|
||||||
|
call divide
|
||||||
|
push bc
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; End of native words
|
||||||
|
|
||||||
|
; ( a -- )
|
||||||
|
; @ .
|
||||||
|
FETCHDOT:
|
||||||
|
.db "?"
|
||||||
|
.fill 7
|
||||||
|
.dw DIV
|
||||||
|
.dw compiledWord
|
||||||
|
.dw FETCH+CODELINK_OFFSET
|
||||||
|
.dw DOT+CODELINK_OFFSET
|
||||||
|
.dw EXIT+CODELINK_OFFSET
|
||||||
|
|
||||||
|
; ( n a -- )
|
||||||
|
; SWAP OVER @ + SWAP !
|
||||||
|
STOREINC:
|
||||||
|
.db "+!"
|
||||||
|
.fill 6
|
||||||
|
.dw FETCHDOT
|
||||||
|
.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
|
||||||
|
|
||||||
|
; ( n -- )
|
||||||
|
; HERE +!
|
||||||
|
ALLOT:
|
||||||
|
.db "ALLOT", 0, 0, 0
|
||||||
|
.dw STOREINC
|
||||||
|
.dw compiledWord
|
||||||
|
.dw HERE_+CODELINK_OFFSET
|
||||||
|
.dw STOREINC+CODELINK_OFFSET
|
||||||
|
.dw EXIT+CODELINK_OFFSET
|
||||||
|
|
||||||
|
; CREATE 2 ALLOT
|
||||||
|
VARIABLE:
|
||||||
|
.db "VARIABLE"
|
||||||
|
.dw ALLOT
|
||||||
|
.dw compiledWord
|
||||||
|
.dw CREATE+CODELINK_OFFSET
|
||||||
|
.dw NUMBER
|
||||||
|
.dw 2
|
||||||
|
.dw ALLOT+CODELINK_OFFSET
|
||||||
|
.dw EXIT+CODELINK_OFFSET
|
||||||
|
|
||||||
|
; ( n -- )
|
||||||
|
; CREATE HERE @ ! DOES> @
|
||||||
|
CONSTANT:
|
||||||
|
.db "CONSTANT"
|
||||||
|
.dw VARIABLE
|
||||||
|
.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
|
||||||
|
|
48
apps/forth/dictionary.txt
Normal file
48
apps/forth/dictionary.txt
Normal file
@ -0,0 +1,48 @@
|
|||||||
|
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.
|
||||||
|
|
||||||
|
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>.
|
||||||
|
|
||||||
|
"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>.
|
||||||
|
|
||||||
|
Example: ": CONSTANT CREATE HERE @ ! DOES> @ ;"
|
||||||
|
|
||||||
|
*** Native Words ***
|
||||||
|
|
||||||
|
: x ... ; -- Define a new word
|
||||||
|
. n -- Print n in its decimal form
|
||||||
|
@ a -- n Set n to value at address a
|
||||||
|
! n a -- Store n in address a
|
||||||
|
+ a b -- c a + b -> c
|
||||||
|
- a b -- c a - b -> c
|
||||||
|
* a b -- c a * b -> c
|
||||||
|
/ a b -- c a / b -> c
|
||||||
|
CREATE x -- Create cell named x. Doesn't allocate a PF.
|
||||||
|
DOES> -- See description at top of file
|
||||||
|
DUP a -- a a
|
||||||
|
EMIT c -- Spit char c to stdout
|
||||||
|
EXECUTE a -- Execute word at addr a
|
||||||
|
EXIT R:I -- Exit a colon definition
|
||||||
|
HERE -- a Push HERE's address
|
||||||
|
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
|
||||||
|
|
||||||
|
*** Core-but-Forth Words ***
|
||||||
|
|
||||||
|
? a -- Print value of addr a
|
||||||
|
+! n a -- Increase value of addr a by n
|
||||||
|
ALLOT n -- Move HERE by n bytes
|
||||||
|
CONSTANT x n -- Creates cell x that when called pushes its value
|
||||||
|
VARIABLE c -- Creates cell x with 2 bytes allocation.
|
14
apps/forth/glue.asm
Normal file
14
apps/forth/glue.asm
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
.inc "user.h"
|
||||||
|
jp forthMain
|
||||||
|
|
||||||
|
.inc "core.asm"
|
||||||
|
.inc "lib/util.asm"
|
||||||
|
.inc "lib/parse.asm"
|
||||||
|
.inc "lib/ari.asm"
|
||||||
|
.inc "lib/fmt.asm"
|
||||||
|
.equ FORTH_RAMSTART RAMSTART
|
||||||
|
.inc "forth/main.asm"
|
||||||
|
.inc "forth/util.asm"
|
||||||
|
.inc "forth/stack.asm"
|
||||||
|
.inc "forth/dict.asm"
|
||||||
|
RAMSTART:
|
77
apps/forth/main.asm
Normal file
77
apps/forth/main.asm
Normal file
@ -0,0 +1,77 @@
|
|||||||
|
; *** Const ***
|
||||||
|
; Base of the Return Stack
|
||||||
|
.equ RS_ADDR 0xf000
|
||||||
|
; 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
|
||||||
|
; 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
|
||||||
|
|
||||||
|
; *** 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 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
|
||||||
|
; (which can end up being prohibitive in terms of costs), we give
|
||||||
|
; ourselves a nice 6 bytes buffer. 6 bytes because we seldom have words
|
||||||
|
; requiring more than 3 items from the stack. Then, at each "exit" call
|
||||||
|
; we check for stack underflow.
|
||||||
|
push af \ push af \ push af
|
||||||
|
ld (INITIAL_SP), sp
|
||||||
|
ld hl, CONSTANT ; last entry in hardcoded dict
|
||||||
|
ld (CURRENT), hl
|
||||||
|
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
|
||||||
|
jp executeCodeLink
|
||||||
|
msgOk:
|
||||||
|
.db " ok", 0
|
41
apps/forth/stack.asm
Normal file
41
apps/forth/stack.asm
Normal file
@ -0,0 +1,41 @@
|
|||||||
|
; The Parameter stack (PS) is maintained by SP and the Return stack (RS) is
|
||||||
|
; maintained by IX. This allows us to generally use push and pop freely because
|
||||||
|
; 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.
|
||||||
|
;
|
||||||
|
; 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:
|
||||||
|
ld (ix), l
|
||||||
|
inc ix
|
||||||
|
ld (ix), h
|
||||||
|
inc ix
|
||||||
|
ret
|
||||||
|
|
||||||
|
; Pop RS' TOS to HL
|
||||||
|
popRS:
|
||||||
|
dec ix
|
||||||
|
ld h, (ix)
|
||||||
|
dec ix
|
||||||
|
ld l, (ix)
|
||||||
|
ret
|
||||||
|
|
||||||
|
; Verifies that SP is within bounds. If it's not, call ABORT
|
||||||
|
chkPS:
|
||||||
|
ld hl, (INITIAL_SP)
|
||||||
|
; We have the return address for this very call on the stack. Let's
|
||||||
|
; compensate
|
||||||
|
dec hl \ dec hl
|
||||||
|
or a ; clear carry
|
||||||
|
sbc hl, sp
|
||||||
|
ret nc ; (INITIAL_SP) >= SP? good
|
||||||
|
; underflow
|
||||||
|
ld hl, .msg
|
||||||
|
call printstr
|
||||||
|
jp abort
|
||||||
|
.msg:
|
||||||
|
.db "stack underflow", 0
|
132
apps/forth/util.asm
Normal file
132
apps/forth/util.asm
Normal file
@ -0,0 +1,132 @@
|
|||||||
|
; Return address of scratchpad in HL
|
||||||
|
pad:
|
||||||
|
ld hl, (HERE)
|
||||||
|
ld a, PADDING
|
||||||
|
jp addHL
|
||||||
|
|
||||||
|
; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
|
||||||
|
; Advance (INPUTPOS) to the character following the whitespace ending the
|
||||||
|
; word.
|
||||||
|
; Z set of word was read, unset if end of line.
|
||||||
|
readword:
|
||||||
|
ld hl, (INPUTPOS)
|
||||||
|
; skip leading whitespace
|
||||||
|
dec hl ; offset leading "inc hl"
|
||||||
|
.loop1:
|
||||||
|
inc hl
|
||||||
|
ld a, (hl)
|
||||||
|
or a
|
||||||
|
jr z, .empty
|
||||||
|
cp ' '+1
|
||||||
|
jr c, .loop1
|
||||||
|
push hl ; --> lvl 1. that's our result
|
||||||
|
.loop2:
|
||||||
|
inc hl
|
||||||
|
ld a, (hl)
|
||||||
|
; special case: is A null? If yes, we will *not* inc A so that we don't
|
||||||
|
; go over the bounds of our input string.
|
||||||
|
or a
|
||||||
|
jr z, .noinc
|
||||||
|
cp ' '+1
|
||||||
|
jr nc, .loop2
|
||||||
|
; we've just read a whitespace, HL is pointing to it. Let's transform
|
||||||
|
; it into a null-termination, inc HL, then set (INPUTPOS).
|
||||||
|
xor a
|
||||||
|
ld (hl), a
|
||||||
|
inc hl
|
||||||
|
.noinc:
|
||||||
|
ld (INPUTPOS), hl
|
||||||
|
pop hl ; <-- lvl 1. our result
|
||||||
|
ret ; Z set from XOR A
|
||||||
|
.empty:
|
||||||
|
ld (hl), a
|
||||||
|
inc a ; unset Z
|
||||||
|
ret
|
||||||
|
|
||||||
|
; For DE pointing to a dict entry, set DE to point to the previous entry.
|
||||||
|
; 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
|
||||||
|
call intoDE
|
||||||
|
; DE points to prev. Is it zero?
|
||||||
|
xor a
|
||||||
|
or d
|
||||||
|
or e
|
||||||
|
; Z will be set if DE is zero
|
||||||
|
ret
|
||||||
|
|
||||||
|
; Find the entry corresponding to word where (HL) points to and sets DE to
|
||||||
|
; point to that entry.
|
||||||
|
; Z if found, NZ if not.
|
||||||
|
find:
|
||||||
|
ld de, (CURRENT)
|
||||||
|
.inner:
|
||||||
|
ld a, NAMELEN
|
||||||
|
call strncmp
|
||||||
|
ret z ; found
|
||||||
|
call prev
|
||||||
|
jr nz, .inner
|
||||||
|
; Z set? end of dict unset Z
|
||||||
|
inc a
|
||||||
|
ret
|
||||||
|
|
||||||
|
; Write compiled data from HL into IY, advancing IY at the same time.
|
||||||
|
wrCompHL:
|
||||||
|
ld (iy), l
|
||||||
|
inc iy
|
||||||
|
ld (iy), h
|
||||||
|
inc iy
|
||||||
|
ret
|
||||||
|
|
||||||
|
; 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
|
||||||
|
jr wrCompHL
|
||||||
|
.maybeNum:
|
||||||
|
call parseLiteral
|
||||||
|
ret nz
|
||||||
|
; 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
|
||||||
|
|
||||||
|
; 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
|
||||||
|
ld de, (HERE)
|
||||||
|
call strcpy
|
||||||
|
ex de, hl ; (HERE) now in HL
|
||||||
|
ld de, (CURRENT)
|
||||||
|
ld (CURRENT), hl
|
||||||
|
ld a, NAMELEN
|
||||||
|
call addHL
|
||||||
|
ld (hl), e
|
||||||
|
inc hl
|
||||||
|
ld (hl), d
|
||||||
|
inc hl
|
||||||
|
ld (HERE), hl
|
||||||
|
xor a ; set Z
|
||||||
|
ret
|
1
emul/.gitignore
vendored
1
emul/.gitignore
vendored
@ -8,4 +8,5 @@
|
|||||||
/cfsin/zasm
|
/cfsin/zasm
|
||||||
/cfsin/ed
|
/cfsin/ed
|
||||||
/cfsin/basic
|
/cfsin/basic
|
||||||
|
/cfsin/forth
|
||||||
/cfsin/user.h
|
/cfsin/user.h
|
||||||
|
@ -4,7 +4,7 @@ KERNEL = ../kernel
|
|||||||
APPS = ../apps
|
APPS = ../apps
|
||||||
ZASMBIN = zasm/zasm
|
ZASMBIN = zasm/zasm
|
||||||
AVRABIN = zasm/avra
|
AVRABIN = zasm/avra
|
||||||
SHELLAPPS = zasm ed
|
SHELLAPPS = zasm ed forth
|
||||||
SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
|
SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
|
||||||
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
|
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
|
||||||
OBJS = emul.o libz80/libz80.o
|
OBJS = emul.o libz80/libz80.o
|
||||||
|
Loading…
Reference in New Issue
Block a user