997 lines
13 KiB
NASM
997 lines
13 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 popRSIP
|
|
jp next
|
|
|
|
; ( R:I -- )
|
|
.db "QUIT"
|
|
.fill 3
|
|
.dw EXIT
|
|
.db 0
|
|
QUIT:
|
|
.dw nativeWord
|
|
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
|
|
|
|
.db ","
|
|
.fill 6
|
|
.dw PFETCH
|
|
.db 0
|
|
WR:
|
|
.dw nativeWord
|
|
pop de
|
|
call chkPS
|
|
ld hl, (HERE)
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
|
|
; ( addr -- )
|
|
.db "EXECUTE"
|
|
.dw WR
|
|
.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 compiledWord
|
|
.dw FIND_
|
|
.dw CSKIP
|
|
.dw .maybeNum
|
|
.dw DUP
|
|
.dw ISIMMED
|
|
.dw CSKIP
|
|
.dw .word
|
|
; is immediate. just execute.
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
|
|
.db 0b10 ; UNWORD
|
|
.word:
|
|
.dw compiledWord
|
|
.dw WR
|
|
.dw R2P ; exit COMPILE
|
|
.dw DROP
|
|
.dw EXIT
|
|
|
|
.db 0b10 ; UNWORD
|
|
.maybeNum:
|
|
.dw compiledWord
|
|
.dw PARSEI
|
|
.dw LITN
|
|
.dw R2P ; exit COMPILE
|
|
.dw DROP
|
|
.dw EXIT
|
|
|
|
|
|
.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 popRSIP
|
|
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
|
|
|
|
|
|
.db "IMMED?"
|
|
.fill 1
|
|
.dw IMMEDIATE
|
|
.db 0
|
|
ISIMMED:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
dec hl
|
|
ld de, 0
|
|
bit FLAG_IMMED, (hl)
|
|
jr z, .notset
|
|
inc de
|
|
.notset:
|
|
push de
|
|
jp next
|
|
|
|
; ( n -- )
|
|
.db "LITN"
|
|
.fill 3
|
|
.dw ISIMMED
|
|
.db 0
|
|
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 "(find)"
|
|
.fill 1
|
|
.dw LITS
|
|
.db 0
|
|
FIND_:
|
|
.dw nativeWord
|
|
call readword
|
|
call find
|
|
jr z, .found
|
|
; not found
|
|
push hl
|
|
ld de, 0
|
|
push de
|
|
jp next
|
|
.found:
|
|
push de
|
|
ld de, 1
|
|
push de
|
|
jp next
|
|
|
|
.db "'"
|
|
.fill 6
|
|
.dw FIND_
|
|
.db 0
|
|
FIND:
|
|
.dw compiledWord
|
|
.dw FIND_
|
|
.dw CSKIP
|
|
.dw FINDERR
|
|
.dw EXIT
|
|
|
|
.db "[']"
|
|
.fill 4
|
|
.dw FIND
|
|
.db 0b01 ; IMMEDIATE
|
|
FINDI:
|
|
.dw compiledWord
|
|
.dw FIND_
|
|
.dw CSKIP
|
|
.dw FINDERR
|
|
.dw LITN
|
|
.dw EXIT
|
|
|
|
.db 0b10 ; UNWORD
|
|
FINDERR:
|
|
.dw compiledWord
|
|
.dw DROP ; Drop str addr, we don't use it
|
|
.dw LIT
|
|
.db "word not found", 0
|
|
.dw PRINT
|
|
.dw ABORT
|
|
|
|
; ( -- 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 "(parsed"
|
|
.dw WORD
|
|
.db 0
|
|
PARSED:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
call parseDecimal
|
|
jr z, .success
|
|
; error
|
|
ld de, 0
|
|
push de ; dummy
|
|
push de ; flag
|
|
jp next
|
|
.success:
|
|
push de
|
|
ld de, 1 ; flag
|
|
push de
|
|
jp next
|
|
|
|
|
|
.db "(parse)"
|
|
.dw PARSED
|
|
.db 0
|
|
PARSE:
|
|
.dw compiledWord
|
|
.dw PARSED
|
|
.dw CSKIP
|
|
.dw .error
|
|
; success, stack is already good, we can exit
|
|
.dw EXIT
|
|
|
|
.db 0b10 ; UNWORD
|
|
.error:
|
|
.dw compiledWord
|
|
.dw LIT
|
|
.db "unknown word", 0
|
|
.dw PRINT
|
|
.dw ABORT
|
|
|
|
|
|
; Indirect parse caller. Reads PARSEPTR and calls
|
|
.db 0b10 ; UNWORD
|
|
PARSEI:
|
|
.dw compiledWord
|
|
.dw PARSEPTR_
|
|
.dw FETCH
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
|
|
|
|
.db "CREATE"
|
|
.fill 1
|
|
.dw PARSE
|
|
.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 "(parse*"
|
|
.dw CURRENT_
|
|
.db 0
|
|
PARSEPTR_:
|
|
.dw sysvarWord
|
|
.dw PARSEPTR
|
|
|
|
.db "IN>"
|
|
.fill 4
|
|
.dw PARSEPTR_
|
|
.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
|