1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-02 14:30:55 +11:00

Compare commits

..

11 Commits

Author SHA1 Message Date
Virgil Dupras
5cadde557c forth: add "VARIABLE" 2020-03-07 22:23:08 -05:00
Virgil Dupras
989d8bbabf forth: add "DOES>" and "CONSTANT" 2020-03-07 22:18:14 -05:00
Virgil Dupras
53024d88f5 forth: add "DUP", "OVER", "SWAP", "?", "+!", "ALLOT" 2020-03-07 21:12:30 -05:00
Virgil Dupras
f0cf10ab7c forth: Check for PS underflow 2020-03-07 20:20:11 -05:00
Virgil Dupras
580214426a forth: add +-*/ 2020-03-07 19:42:07 -05:00
Virgil Dupras
ad2aca4620 forth: add number literals support 2020-03-07 19:25:55 -05:00
Virgil Dupras
30f188b984 forth: add word ":" 2020-03-07 18:54:16 -05:00
Virgil Dupras
e7cd3182d0 forth: add words "CREATE", "@", "!", "HERE", "QUIT" 2020-03-07 17:09:45 -05:00
Virgil Dupras
6f9d28b325 forth: add word "bye"
And make interpret action looping until BYE.
2020-03-07 13:15:19 -05:00
Virgil Dupras
391ddb9984 forth: add word "." 2020-03-07 12:50:54 -05:00
Virgil Dupras
49228e418c apps/forth: new (WIP) application 2020-03-07 12:13:15 -05:00
9 changed files with 778 additions and 1 deletions

7
apps/forth/README.md Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -8,4 +8,5 @@
/cfsin/zasm
/cfsin/ed
/cfsin/basic
/cfsin/forth
/cfsin/user.h

View File

@ -4,7 +4,7 @@ KERNEL = ../kernel
APPS = ../apps
ZASMBIN = zasm/zasm
AVRABIN = zasm/avra
SHELLAPPS = zasm ed
SHELLAPPS = zasm ed forth
SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
OBJS = emul.o libz80/libz80.o