mirror of
https://github.com/hsoft/collapseos.git
synced 2024-07-23 17:10:19 +10:00
80ab395823
Change the mainloop so that words are executed immediately after they're read. This greatly simplifies execution model and allow the "DEFINE" word to become an IMMEDIATE and stop its "copy from compiled words" scheme. The downside to this is that flow control words no longer work when being used directly in the input buffer. They only work as part of a definition. It also broke "RECURSE", but I've replaced it with "BEGIN" and "AGAIN". Another effect of this change is that definitions can now span multiple lines. All in all, it feels good to get rid of that COMPBUF...
827 lines
11 KiB
NASM
827 lines
11 KiB
NASM
; A dictionary entry has this structure:
|
|
; - 7b name (zero-padded)
|
|
; - 2b prev pointer
|
|
; - 1b flags (bit 0: IMMEDIATE. bit 1: UNWORD)
|
|
; - 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 (IP). They will usually do so with "jp next".
|
|
;
|
|
; That's for "regular" words (words that are part of the dict chain). There are
|
|
; also "special words", for example NUMBER, LIT, FBR, that have a slightly
|
|
; different structure. They're also a pointer to an executable, but as for the
|
|
; other fields, the only one they have is the "flags" field.
|
|
|
|
; This routine is jumped to at the end of every word. In it, we jump to current
|
|
; IP, but we also take care of increasing it my 2 before jumping
|
|
next:
|
|
; Before we continue: are stacks within bounds?
|
|
call chkPSRS
|
|
ld de, (IP)
|
|
ld h, d
|
|
ld l, e
|
|
inc de \ inc de
|
|
ld (IP), de
|
|
; HL is an atom list pointer. We need to go into it to have a wordref
|
|
ld e, (hl)
|
|
inc hl
|
|
ld d, (hl)
|
|
push de
|
|
jp EXECUTE+2
|
|
|
|
|
|
; Execute a word containing native code at its PF address (PFA)
|
|
nativeWord:
|
|
jp (iy)
|
|
|
|
; Execute a list of atoms, which always end with EXIT.
|
|
; IY points to that list. What do we do:
|
|
; 1. Push current IP to RS
|
|
; 2. Set new IP to the second atom of the list
|
|
; 3. Execute the first atom of the list.
|
|
compiledWord:
|
|
ld hl, (IP)
|
|
call pushRS
|
|
push iy \ pop hl
|
|
inc hl
|
|
inc hl
|
|
ld (IP), hl
|
|
; IY still is our atom reference...
|
|
ld l, (iy)
|
|
ld h, (iy+1)
|
|
push hl ; argument for EXECUTE
|
|
jp EXECUTE+2
|
|
|
|
; Pushes the PFA directly
|
|
cellWord:
|
|
push iy
|
|
jp next
|
|
|
|
; Pushes the address in the first word of the PF
|
|
sysvarWord:
|
|
ld l, (iy)
|
|
ld h, (iy+1)
|
|
push hl
|
|
jp next
|
|
|
|
; 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 IP.
|
|
numberWord:
|
|
ld hl, (IP) ; (HL) is out number
|
|
ld e, (hl)
|
|
inc hl
|
|
ld d, (hl)
|
|
inc hl
|
|
ld (IP), hl ; advance IP by 2
|
|
push de
|
|
jp next
|
|
|
|
.db 0b10 ; Flags
|
|
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. When called, puts the string's address on PS
|
|
litWord:
|
|
ld hl, (IP)
|
|
push hl
|
|
call strskip
|
|
inc hl ; after null termination
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
.db 0b10 ; Flags
|
|
LIT:
|
|
.dw litWord
|
|
|
|
; Pop previous IP from Return stack and execute it.
|
|
; ( R:I -- )
|
|
.db "EXIT"
|
|
.fill 3
|
|
.dw 0
|
|
.db 0
|
|
EXIT:
|
|
.dw nativeWord
|
|
call popRS
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
; ( R:I -- )
|
|
.db "QUIT"
|
|
.fill 3
|
|
.dw EXIT
|
|
.db 0
|
|
QUIT:
|
|
.dw nativeWord
|
|
quit:
|
|
jp forthRdLine
|
|
|
|
.db "ABORT"
|
|
.fill 2
|
|
.dw QUIT
|
|
.db 0
|
|
ABORT:
|
|
.dw nativeWord
|
|
abort:
|
|
; flush rest of input
|
|
ld hl, (INPUTPOS)
|
|
xor a
|
|
ld (hl), a
|
|
; Reinitialize PS (RS is reinitialized in forthInterpret)
|
|
ld sp, (INITIAL_SP)
|
|
jp forthRdLineNoOk
|
|
|
|
; prints msg in (HL) then aborts
|
|
abortMsg:
|
|
call printstr
|
|
jr abort
|
|
|
|
abortUnknownWord:
|
|
ld hl, .msg
|
|
jr abortMsg
|
|
.msg:
|
|
.db "unknown word", 0
|
|
|
|
.db "BYE"
|
|
.fill 4
|
|
.dw ABORT
|
|
.db 0
|
|
BYE:
|
|
.dw nativeWord
|
|
; 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 -- )
|
|
.db "EMIT"
|
|
.fill 3
|
|
.dw BYE
|
|
.db 0
|
|
EMIT:
|
|
.dw nativeWord
|
|
pop hl
|
|
ld a, l
|
|
call stdioPutC
|
|
jp next
|
|
|
|
; ( c port -- )
|
|
.db "PC!"
|
|
.fill 4
|
|
.dw EMIT
|
|
.db 0
|
|
PSTORE:
|
|
.dw nativeWord
|
|
pop bc
|
|
pop hl
|
|
out (c), l
|
|
jp next
|
|
|
|
; ( port -- c )
|
|
.db "PC@"
|
|
.fill 4
|
|
.dw PSTORE
|
|
.db 0
|
|
PFETCH:
|
|
.dw nativeWord
|
|
pop bc
|
|
ld h, 0
|
|
in l, (c)
|
|
push hl
|
|
jp next
|
|
|
|
; ( addr -- )
|
|
.db "EXECUTE"
|
|
.dw PFETCH
|
|
.db 0
|
|
EXECUTE:
|
|
.dw nativeWord
|
|
pop iy ; is a wordref
|
|
ld l, (iy)
|
|
ld h, (iy+1)
|
|
; HL points to code pointer
|
|
inc iy
|
|
inc iy
|
|
; IY points to PFA
|
|
jp (hl) ; go!
|
|
|
|
|
|
.db "COMPILE"
|
|
.dw EXECUTE
|
|
.db 1 ; IMMEDIATE
|
|
COMPILE:
|
|
.dw nativeWord
|
|
call readword
|
|
call find
|
|
jr nz, .maybeNum
|
|
ex de, hl
|
|
call HLisIMMED
|
|
jr z, .immed
|
|
ex de, hl
|
|
call .writeDE
|
|
jp next
|
|
.maybeNum:
|
|
push hl ; --> lvl 1. save string addr
|
|
call parseLiteral
|
|
pop hl ; <-- lvl 1
|
|
jr nz, .undef
|
|
; a valid number in DE!
|
|
ex de, hl
|
|
ld de, NUMBER
|
|
call .writeDE
|
|
ex de, hl ; number in DE
|
|
call .writeDE
|
|
jp next
|
|
.undef:
|
|
call printstr
|
|
jp abortUnknownWord
|
|
.immed:
|
|
push hl
|
|
jp EXECUTE+2
|
|
.writeDE:
|
|
push hl
|
|
ld hl, (HERE)
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
pop hl
|
|
ret
|
|
|
|
|
|
.db ":"
|
|
.fill 6
|
|
.dw COMPILE
|
|
.db 1 ; IMMEDIATE
|
|
DEFINE:
|
|
.dw nativeWord
|
|
call entryhead
|
|
ld de, compiledWord
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
.loop:
|
|
; did we reach ";"?
|
|
ld hl, (INPUTPOS)
|
|
ld a, (hl)
|
|
cp ';'
|
|
jr nz, .compile
|
|
inc hl
|
|
ld a, (hl)
|
|
cp ' '+1
|
|
jr c, .loopend ; whitespace, we have semicol. end
|
|
.compile:
|
|
ld hl, (IP)
|
|
call pushRS
|
|
ld hl, .retRef
|
|
ld (IP), hl
|
|
ld hl, COMPILE
|
|
push hl
|
|
jp EXECUTE+2
|
|
.loopend:
|
|
; Advance (INPUTPOS) to after semicol. HL is already there.
|
|
ld (INPUTPOS), hl
|
|
; write EXIT and return
|
|
ld hl, (HERE)
|
|
ld de, EXIT
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp next
|
|
.retRef:
|
|
.dw $+2
|
|
.dw $+2
|
|
call popRS
|
|
ld (IP), hl
|
|
jr .loop
|
|
|
|
|
|
.db "DOES>"
|
|
.fill 2
|
|
.dw DEFINE
|
|
.db 0
|
|
DOES:
|
|
.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. Write down IP+2 to entry.
|
|
; 3. exit. we're done here.
|
|
ld iy, (CURRENT)
|
|
ld hl, doesWord
|
|
call wrCompHL
|
|
inc iy \ inc iy ; cell variable space
|
|
ld hl, (IP)
|
|
call wrCompHL
|
|
ld (HERE), iy
|
|
jp EXIT+2
|
|
|
|
|
|
.db "IMMEDIA"
|
|
.dw DOES
|
|
.db 0
|
|
IMMEDIATE:
|
|
.dw nativeWord
|
|
ld hl, (CURRENT)
|
|
dec hl
|
|
set FLAG_IMMED, (hl)
|
|
jp next
|
|
|
|
; ( n -- )
|
|
.db "LITN"
|
|
.fill 3
|
|
.dw IMMEDIATE
|
|
.db 1 ; IMMEDIATE
|
|
LITN:
|
|
.dw nativeWord
|
|
ld hl, (HERE)
|
|
ld de, NUMBER
|
|
call DEinHL
|
|
pop de ; number from stack
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
.db "LITS"
|
|
.fill 3
|
|
.dw LITN
|
|
.db 1 ; IMMEDIATE
|
|
LITS:
|
|
.dw nativeWord
|
|
ld hl, (HERE)
|
|
ld de, LIT
|
|
call DEinHL
|
|
ex de, hl ; (HERE) in DE
|
|
call readword
|
|
call strcpyM
|
|
ld (HERE), de
|
|
jp next
|
|
|
|
.db "'"
|
|
.fill 6
|
|
.dw LITS
|
|
.db 0
|
|
APOS:
|
|
.dw nativeWord
|
|
call readword
|
|
call find
|
|
jr nz, .notfound
|
|
push de
|
|
jp next
|
|
.notfound:
|
|
ld hl, .msg
|
|
call printstr
|
|
jp abort
|
|
.msg:
|
|
.db "word not found", 0
|
|
|
|
.db "[']"
|
|
.fill 4
|
|
.dw APOS
|
|
.db 0b01 ; IMMEDIATE
|
|
APOSI:
|
|
.dw nativeWord
|
|
call readword
|
|
call find
|
|
jr nz, .notfound
|
|
ld hl, (HERE)
|
|
push de ; --> lvl 1
|
|
ld de, NUMBER
|
|
call DEinHL
|
|
pop de ; <-- lvl 1
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp next
|
|
.notfound:
|
|
ld hl, .msg
|
|
call printstr
|
|
jp abort
|
|
.msg:
|
|
.db "word not found", 0
|
|
|
|
; ( -- c )
|
|
.db "KEY"
|
|
.fill 4
|
|
.dw APOSI
|
|
.db 0
|
|
KEY:
|
|
.dw nativeWord
|
|
call stdioGetC
|
|
ld h, 0
|
|
ld l, a
|
|
push hl
|
|
jp next
|
|
|
|
.db "WORD"
|
|
.fill 3
|
|
.dw KEY
|
|
.db 0
|
|
WORD:
|
|
.dw nativeWord
|
|
call readword
|
|
push hl
|
|
jp next
|
|
|
|
.db "CREATE"
|
|
.fill 1
|
|
.dw WORD
|
|
.db 0
|
|
CREATE:
|
|
.dw nativeWord
|
|
call entryhead
|
|
ld de, cellWord
|
|
ld (hl), e
|
|
inc hl
|
|
ld (hl), d
|
|
inc hl
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
.db "HERE"
|
|
.fill 3
|
|
.dw CREATE
|
|
.db 0
|
|
HERE_: ; Caution: conflicts with actual variable name
|
|
.dw sysvarWord
|
|
.dw HERE
|
|
|
|
.db "CURRENT"
|
|
.dw HERE_
|
|
.db 0
|
|
CURRENT_:
|
|
.dw sysvarWord
|
|
.dw CURRENT
|
|
|
|
.db "IN>"
|
|
.fill 4
|
|
.dw CURRENT_
|
|
.db 0
|
|
INP:
|
|
.dw sysvarWord
|
|
.dw INPUTPOS
|
|
|
|
; ( n -- )
|
|
.db "."
|
|
.fill 6
|
|
.dw INP
|
|
.db 0
|
|
DOT:
|
|
.dw nativeWord
|
|
pop de
|
|
; We check PS explicitly because it doesn't look nice to spew gibberish
|
|
; before aborting the stack underflow.
|
|
call chkPSRS
|
|
call pad
|
|
call fmtDecimalS
|
|
call printstr
|
|
jp next
|
|
|
|
; ( n a -- )
|
|
.db "!"
|
|
.fill 6
|
|
.dw DOT
|
|
.db 0
|
|
STORE:
|
|
.dw nativeWord
|
|
pop iy
|
|
pop hl
|
|
ld (iy), l
|
|
ld (iy+1), h
|
|
jp next
|
|
|
|
; ( n a -- )
|
|
.db "C!"
|
|
.fill 5
|
|
.dw STORE
|
|
.db 0
|
|
CSTORE:
|
|
.dw nativeWord
|
|
pop hl
|
|
pop de
|
|
ld (hl), e
|
|
jp next
|
|
|
|
; ( a -- n )
|
|
.db "@"
|
|
.fill 6
|
|
.dw CSTORE
|
|
.db 0
|
|
FETCH:
|
|
.dw nativeWord
|
|
pop hl
|
|
call intoHL
|
|
push hl
|
|
jp next
|
|
|
|
; ( a -- c )
|
|
.db "C@"
|
|
.fill 5
|
|
.dw FETCH
|
|
.db 0
|
|
CFETCH:
|
|
.dw nativeWord
|
|
pop hl
|
|
ld l, (hl)
|
|
ld h, 0
|
|
push hl
|
|
jp next
|
|
|
|
; ( a -- )
|
|
.db "DROP"
|
|
.fill 3
|
|
.dw CFETCH
|
|
.db 0
|
|
DROP:
|
|
.dw nativeWord
|
|
pop hl
|
|
jp next
|
|
|
|
; ( a b -- b a )
|
|
.db "SWAP"
|
|
.fill 3
|
|
.dw DROP
|
|
.db 0
|
|
SWAP:
|
|
.dw nativeWord
|
|
pop hl
|
|
ex (sp), hl
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b c d -- c d a b )
|
|
.db "2SWAP"
|
|
.fill 2
|
|
.dw SWAP
|
|
.db 0
|
|
SWAP2:
|
|
.dw nativeWord
|
|
pop de ; D
|
|
pop hl ; C
|
|
pop bc ; B
|
|
|
|
ex (sp), hl ; A in HL
|
|
push de ; D
|
|
push hl ; A
|
|
push bc ; B
|
|
jp next
|
|
|
|
; ( a -- a a )
|
|
.db "DUP"
|
|
.fill 4
|
|
.dw SWAP2
|
|
.db 0
|
|
DUP:
|
|
.dw nativeWord
|
|
pop hl
|
|
push hl
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- a b a b )
|
|
.db "2DUP"
|
|
.fill 3
|
|
.dw DUP
|
|
.db 0
|
|
DUP2:
|
|
.dw nativeWord
|
|
pop hl ; B
|
|
pop de ; A
|
|
push de
|
|
push hl
|
|
push de
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- a b a )
|
|
.db "OVER"
|
|
.fill 3
|
|
.dw DUP2
|
|
.db 0
|
|
OVER:
|
|
.dw nativeWord
|
|
pop hl ; B
|
|
pop de ; A
|
|
push de
|
|
push hl
|
|
push de
|
|
jp next
|
|
|
|
; ( a b c d -- a b c d a b )
|
|
.db "2OVER"
|
|
.fill 2
|
|
.dw OVER
|
|
.db 0
|
|
OVER2:
|
|
.dw nativeWord
|
|
pop hl ; D
|
|
pop de ; C
|
|
pop bc ; B
|
|
pop iy ; A
|
|
push iy ; A
|
|
push bc ; B
|
|
push de ; C
|
|
push hl ; D
|
|
push iy ; A
|
|
push bc ; B
|
|
jp next
|
|
|
|
.db ">R"
|
|
.fill 5
|
|
.dw OVER2
|
|
.db 0
|
|
P2R:
|
|
.dw nativeWord
|
|
pop hl
|
|
call pushRS
|
|
jp next
|
|
|
|
.db "R>"
|
|
.fill 5
|
|
.dw P2R
|
|
.db 0
|
|
R2P:
|
|
.dw nativeWord
|
|
call popRS
|
|
push hl
|
|
jp next
|
|
|
|
.db "I"
|
|
.fill 6
|
|
.dw R2P
|
|
.db 0
|
|
I:
|
|
.dw nativeWord
|
|
ld l, (ix)
|
|
ld h, (ix+1)
|
|
push hl
|
|
jp next
|
|
|
|
.db "I'"
|
|
.fill 5
|
|
.dw I
|
|
.db 0
|
|
IPRIME:
|
|
.dw nativeWord
|
|
ld l, (ix-2)
|
|
ld h, (ix-1)
|
|
push hl
|
|
jp next
|
|
|
|
.db "J"
|
|
.fill 6
|
|
.dw IPRIME
|
|
.db 0
|
|
J:
|
|
.dw nativeWord
|
|
ld l, (ix-4)
|
|
ld h, (ix-3)
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- c ) A + B
|
|
.db "+"
|
|
.fill 6
|
|
.dw J
|
|
.db 0
|
|
PLUS:
|
|
.dw nativeWord
|
|
pop hl
|
|
pop de
|
|
add hl, de
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- c ) A - B
|
|
.db "-"
|
|
.fill 6
|
|
.dw PLUS
|
|
.db 0
|
|
MINUS:
|
|
.dw nativeWord
|
|
pop de ; B
|
|
pop hl ; A
|
|
or a ; reset carry
|
|
sbc hl, de
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- c ) A * B
|
|
.db "*"
|
|
.fill 6
|
|
.dw MINUS
|
|
.db 0
|
|
MULT:
|
|
.dw nativeWord
|
|
pop de
|
|
pop bc
|
|
call multDEBC
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- c ) A / B
|
|
.db "/"
|
|
.fill 6
|
|
.dw MULT
|
|
.db 0
|
|
DIV:
|
|
.dw nativeWord
|
|
pop de
|
|
pop hl
|
|
call divide
|
|
push bc
|
|
jp next
|
|
|
|
; ( a1 a2 -- b )
|
|
.db "SCMP"
|
|
.fill 3
|
|
.dw DIV
|
|
.db 0
|
|
SCMP:
|
|
.dw nativeWord
|
|
pop de
|
|
pop hl
|
|
call strcmp
|
|
call flagsToBC
|
|
push bc
|
|
jp next
|
|
|
|
; ( n1 n2 -- f )
|
|
.db "CMP"
|
|
.fill 4
|
|
.dw SCMP
|
|
.db 0
|
|
CMP:
|
|
.dw nativeWord
|
|
pop hl
|
|
pop de
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
call flagsToBC
|
|
push bc
|
|
jp next
|
|
|
|
.db "SKIP?"
|
|
.fill 2
|
|
.dw CMP
|
|
.db 0
|
|
CSKIP:
|
|
.dw nativeWord
|
|
pop hl
|
|
ld a, h
|
|
or l
|
|
jp z, next ; False, do nothing.
|
|
ld hl, (IP)
|
|
call compSkip
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
|
|
; where to branch to. For example, The branching cell of "IF THEN" would
|
|
; contain 3. Add this value to RS.
|
|
.db "(fbr)"
|
|
.fill 2
|
|
.dw CSKIP
|
|
.db 0
|
|
FBR:
|
|
.dw nativeWord
|
|
push de
|
|
ld hl, (IP)
|
|
ld a, (hl)
|
|
call addHL
|
|
ld (IP), hl
|
|
pop de
|
|
jp next
|
|
|
|
.db "(bbr)"
|
|
.fill 2
|
|
.dw FBR
|
|
.db 0
|
|
BBR:
|
|
.dw nativeWord
|
|
ld hl, (IP)
|
|
ld d, 0
|
|
ld e, (hl)
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
LATEST:
|
|
.dw BBR
|