collapseos/apps/forth/dict.asm

903 lines
12 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 chkPS
call chkRS
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
abortUnderflow:
ld hl, .msg
jr abortMsg
.msg:
.db "stack underflow", 0
.db "ABORT", '"'
.fill 1
.dw ABORT
.db 1 ; IMMEDIATE
ABORTI:
.dw compiledWord
.dw PRINTI
.dw .private
.dw EXIT
.db 0b10 ; UNWORD
.private:
.dw nativeWord
ld hl, (HERE)
ld de, ABORT
call DEinHL
ld (HERE), hl
jp next
.db "BYE"
.fill 4
.dw ABORTI
.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
call chkPS
ld a, l
call stdioPutC
jp next
.db "(print)"
.dw EMIT
.db 0
PRINT:
.dw nativeWord
pop hl
call chkPS
call printstr
jp next
.db '.', '"'
.fill 5
.dw PRINT
.db 1 ; IMMEDIATE
PRINTI:
.dw nativeWord
ld hl, (HERE)
ld de, LIT
call DEinHL
ex de, hl ; (HERE) now in DE
ld hl, (INPUTPOS)
.loop:
ld a, (hl)
or a ; null? not cool
jp z, abort
cp '"'
jr z, .loopend
ld (de), a
inc hl
inc de
jr .loop
.loopend:
inc hl ; inputpos to char afterwards
ld (INPUTPOS), hl
; null-terminate LIT
inc de
xor a
ld (de), a
ex de, hl ; (HERE) in HL
ld de, PRINT
call DEinHL
ld (HERE), hl
jp next
; ( c port -- )
.db "PC!"
.fill 4
.dw PRINTI
.db 0
PSTORE:
.dw nativeWord
pop bc
pop hl
call chkPS
out (c), l
jp next
; ( port -- c )
.db "PC@"
.fill 4
.dw PSTORE
.db 0
PFETCH:
.dw nativeWord
pop bc
call chkPS
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
call chkPS
ld l, (iy)
ld h, (iy+1)
; HL points to code pointer
inc iy
inc iy
; IY points to PFA
jp (hl) ; go!
.db "[COMPIL"
.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 ";"?
call toword
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 chkPS
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
FIND:
.dw nativeWord
call readword
call find
jr z, .found
; not found
ld de, 0
.found:
push de
jp next
.db "[']"
.fill 4
.dw FIND
.db 0b01 ; IMMEDIATE
FINDI:
.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 FINDI
.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 a -- )
.db "!"
.fill 6
.dw INP
.db 0
STORE:
.dw nativeWord
pop iy
pop hl
call chkPS
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
call chkPS
ld (hl), e
jp next
; ( a -- n )
.db "@"
.fill 6
.dw CSTORE
.db 0
FETCH:
.dw nativeWord
pop hl
call chkPS
call intoHL
push hl
jp next
; ( a -- c )
.db "C@"
.fill 5
.dw FETCH
.db 0
CFETCH:
.dw nativeWord
pop hl
call chkPS
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
call chkPS
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
call chkPS
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
call chkPS
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
call chkPS
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
call chkPS
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
call chkPS
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 chkPS
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
call chkPS
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
call chkPS
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 chkPS
call multDEBC
push hl
jp next
.db "/MOD"
.fill 3
.dw MULT
.db 0
DIVMOD:
.dw nativeWord
pop de
pop hl
call chkPS
call divide
push hl
push bc
jp next
; ( a1 a2 -- b )
.db "SCMP"
.fill 3
.dw DIVMOD
.db 0
SCMP:
.dw nativeWord
pop de
pop hl
call chkPS
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
call chkPS
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
call chkPS
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