mirror of https://github.com/hsoft/collapseos.git
1418 lines
26 KiB
NASM
1418 lines
26 KiB
NASM
; Collapse OS' Forth
|
|
;
|
|
; Unlike other assembler parts of Collapse OS, this unit is one huge file.
|
|
;
|
|
; I do this because as Forth takes a bigger place, assembler is bound to take
|
|
; less and less place. I am thus consolidating that assembler code in one
|
|
; place so that I have a better visibility of what to minimize.
|
|
;
|
|
; I also want to reduce the featureset of the assembler so that Collapse OS
|
|
; self-hosts in a more compact manner. File include is a big part of the
|
|
; complexity in zasm. If we can get rid of it, we'll be more compact.
|
|
|
|
; *** ABI STABILITY ***
|
|
;
|
|
; This unit needs to have some of its entry points stay at a stable offset.
|
|
; These have a comment over them indicating the expected offset. These should
|
|
; not move until the Grand Bootstrapping operation has been completed.
|
|
;
|
|
; When you see random ".fill" here and there, it's to ensure that stability.
|
|
|
|
; *** Defines ***
|
|
; GETC: address of a GetC routine
|
|
; PUTC: address of a PutC routine
|
|
;
|
|
; Those GetC/PutC routines are hooked through defines and have this API:
|
|
;
|
|
; GetC: Blocks until a character is read from the device and return that
|
|
; character in A.
|
|
;
|
|
; PutC: Write character specified in A onto the device.
|
|
;
|
|
; *** 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
|
|
; Buffer where WORD copies its read word to.
|
|
.equ WORD_BUFSIZE 0x20
|
|
; Allocated space for sysvars (see comment above SYSVCNT)
|
|
.equ SYSV_BUFSIZE 0x10
|
|
|
|
; Flags for the "flag field" of the word structure
|
|
; IMMEDIATE word
|
|
.equ FLAG_IMMED 7
|
|
|
|
; *** Variables ***
|
|
.equ INITIAL_SP RAMSTART
|
|
; wordref of the last entry of the dict.
|
|
.equ CURRENT @+2
|
|
; Pointer to the next free byte in dict.
|
|
.equ HERE @+2
|
|
; Interpreter pointer. See Execution model comment below.
|
|
.equ IP @+2
|
|
; Global flags
|
|
; Bit 0: whether the interpreter is executing a word (as opposed to parsing)
|
|
.equ FLAGS @+2
|
|
; Pointer to the system's number parsing function. It points to then entry that
|
|
; had the "(parse)" name at startup. During stage0, it's out builtin PARSE,
|
|
; but at stage1, it becomes "(parse)" from core.fs. It can also be changed at
|
|
; runtime.
|
|
.equ PARSEPTR @+2
|
|
; Pointer to the word executed by "C<". During stage0, this points to KEY.
|
|
; However, KEY ain't very interactive. This is why we implement a readline
|
|
; interface in Forth, which we plug in during init. If "(c<)" exists in the
|
|
; dict, CINPTR is set to it. Otherwise, we set KEY
|
|
.equ CINPTR @+2
|
|
; Pointer to (emit) word
|
|
.equ EMITPTR @+2
|
|
; Pointer to (print) word
|
|
.equ PRINTPTR @+2
|
|
.equ WORDBUF @+2
|
|
; Sys Vars are variables with their value living in the system RAM segment. We
|
|
; need this mechanisms for core Forth source needing variables. Because core
|
|
; Forth source is pre-compiled, it needs to be able to live in ROM, which means
|
|
; that we can't compile a regular variable in it. SYSVNXT points to the next
|
|
; free space in SYSVBUF. Then, at the word level, it's a regular sysvarWord.
|
|
.equ SYSVNXT @+WORD_BUFSIZE
|
|
.equ SYSVBUF @+2
|
|
.equ RAMEND @+SYSV_BUFSIZE
|
|
|
|
; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0,
|
|
; (HERE) will begin at a strategic place.
|
|
.equ HERE_INITIAL RAMEND
|
|
|
|
; EXECUTION MODEL
|
|
; After having read a line through readline, we want to interpret it. As
|
|
; a general rule, we go like this:
|
|
;
|
|
; 1. read single word from line
|
|
; 2. Can we find the word in dict?
|
|
; 3. If yes, execute that word, goto 1
|
|
; 4. Is it a number?
|
|
; 5. If yes, push that number to PS, goto 1
|
|
; 6. Error: undefined word.
|
|
;
|
|
; EXECUTING A WORD
|
|
;
|
|
; At it's core, executing a word is having the wordref in IY and call
|
|
; EXECUTE. Then, we let the word do its things. Some words are special,
|
|
; but most of them are of the compiledWord type, and that's their execution that
|
|
; we describe here.
|
|
;
|
|
; First of all, at all time during execution, the Interpreter Pointer (IP)
|
|
; points to the wordref we're executing next.
|
|
;
|
|
; When we execute a compiledWord, the first thing we do is push IP to the Return
|
|
; Stack (RS). Therefore, RS' top of stack will contain a wordref to execute
|
|
; next, after we EXIT.
|
|
;
|
|
; At the end of every compiledWord is an EXIT. This pops RS, sets IP to it, and
|
|
; continues.
|
|
|
|
; *** Stable ABI ***
|
|
; Those jumps below are supposed to stay at these offsets, always. If they
|
|
; change bootstrap binaries have to be adjusted because they rely on them.
|
|
; We're at 0 here
|
|
jp forthMain
|
|
.fill 0x11-$
|
|
JUMPTBL:
|
|
jp pushRS
|
|
jp popRS
|
|
jp nativeWord
|
|
jp next
|
|
jp chkPS
|
|
NUMBER:
|
|
.dw numberWord
|
|
LIT:
|
|
.dw litWord
|
|
|
|
; *** Code ***
|
|
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 ix, RS_ADDR
|
|
; LATEST is a label to the latest entry of the dict. This can be
|
|
; overridden if a binary dict has been grafted to the end of this
|
|
; binary
|
|
ld hl, LATEST
|
|
ld (CURRENT), hl
|
|
ld hl, HERE_INITIAL
|
|
ld (HERE), hl
|
|
; Set up PARSEPTR
|
|
ld hl, .parseName
|
|
call find
|
|
ld (PARSEPTR), de
|
|
; Set up EMITPTR
|
|
ld hl, .emitName
|
|
call find
|
|
ld (EMITPTR), de
|
|
; Set up PRINTPTR
|
|
ld hl, .printName
|
|
call find
|
|
ld (PRINTPTR), de
|
|
; Set up CINPTR
|
|
; do we have a (c<) impl?
|
|
ld hl, .cinName
|
|
call find
|
|
jr z, .skip
|
|
; no? then use KEY
|
|
ld hl, .keyName
|
|
call find
|
|
.skip:
|
|
ld (CINPTR), de
|
|
; Set up SYSVNXT
|
|
ld hl, SYSVBUF
|
|
ld (SYSVNXT), hl
|
|
ld hl, BEGIN
|
|
push hl
|
|
jp EXECUTE+2
|
|
|
|
.parseName:
|
|
.db "(parse)", 0
|
|
.cinName:
|
|
.db "(c<)", 0
|
|
.emitName:
|
|
.db "(emit)", 0
|
|
.printName:
|
|
.db "(print)", 0
|
|
.keyName:
|
|
.db "KEY", 0
|
|
|
|
BEGIN:
|
|
.dw compiledWord
|
|
.dw LIT
|
|
.db "(c<$)", 0
|
|
.dw FIND_
|
|
.dw NOT
|
|
.dw CSKIP
|
|
.dw EXECUTE
|
|
.dw INTERPRET
|
|
|
|
INTERPRET:
|
|
.dw compiledWord
|
|
.dw LIT
|
|
.db "INTERPRET", 0
|
|
.dw FIND_
|
|
.dw DROP
|
|
.dw EXECUTE
|
|
|
|
.fill 13
|
|
|
|
; *** Collapse OS lib copy ***
|
|
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
|
|
; Forth and the concept of ASM libs will become obsolete. To facilitate this
|
|
; transition, I make, right now, a copy of the routines actually used by Forth's
|
|
; native core. This also has the effect of reducing binary size right now and
|
|
; give us an idea of Forth's compactness.
|
|
; These routines below are copy/paste from apps/lib and stdio.
|
|
|
|
; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
|
|
; ld must be done little endian, so least significant byte first.
|
|
intoHL:
|
|
push de
|
|
ld e, (hl)
|
|
inc hl
|
|
ld d, (hl)
|
|
ex de, hl
|
|
pop de
|
|
ret
|
|
|
|
; add the value of A into HL
|
|
; affects carry flag according to the 16-bit addition, Z, S and P untouched.
|
|
addHL:
|
|
push de
|
|
ld d, 0
|
|
ld e, a
|
|
add hl, de
|
|
pop de
|
|
ret
|
|
|
|
; Copy string from (HL) in (DE), that is, copy bytes until a null char is
|
|
; encountered. The null char is also copied.
|
|
; HL and DE point to the char right after the null char.
|
|
; B indicates the length of the copied string, including null-termination.
|
|
strcpy:
|
|
ld b, 0
|
|
.loop:
|
|
ld a, (hl)
|
|
ld (de), a
|
|
inc hl
|
|
inc de
|
|
inc b
|
|
or a
|
|
jr nz, .loop
|
|
ret
|
|
|
|
; Compares strings pointed to by HL and DE until one of them hits its null char.
|
|
; If equal, Z is set. If not equal, Z is reset. C is set if HL > DE
|
|
strcmp:
|
|
push hl
|
|
push de
|
|
|
|
.loop:
|
|
ld a, (de)
|
|
cp (hl)
|
|
jr nz, .end ; not equal? break early. NZ is carried out
|
|
; to the caller
|
|
or a ; If our chars are null, stop the cmp
|
|
inc hl
|
|
inc de
|
|
jr nz, .loop ; Z is carried through
|
|
|
|
.end:
|
|
pop de
|
|
pop hl
|
|
; Because we don't call anything else than CP that modify the Z flag,
|
|
; our Z value will be that of the last cp (reset if we broke the loop
|
|
; early, set otherwise)
|
|
ret
|
|
|
|
; Given a string at (HL), move HL until it points to the end of that string.
|
|
strskip:
|
|
push bc
|
|
ex af, af'
|
|
xor a ; look for null char
|
|
ld b, a
|
|
ld c, a
|
|
cpir ; advances HL regardless of comparison, so goes one too far
|
|
dec hl
|
|
ex af, af'
|
|
pop bc
|
|
ret
|
|
|
|
; Parse string at (HL) as a decimal value and return value in DE.
|
|
; Reads as many digits as it can and stop when:
|
|
; 1 - A non-digit character is read
|
|
; 2 - The number overflows from 16-bit
|
|
; HL is advanced to the character following the last successfully read char.
|
|
; Error conditions are:
|
|
; 1 - There wasn't at least one character that could be read.
|
|
; 2 - Overflow.
|
|
; Sets Z on success, unset on error.
|
|
|
|
parseDecimal:
|
|
; First char is special: it has to succeed.
|
|
ld a, (hl)
|
|
cp '-'
|
|
jr z, .negative
|
|
; Parse the decimal char at A and extract it's 0-9 numerical value. Put the
|
|
; result in A.
|
|
; On success, the carry flag is reset. On error, it is set.
|
|
add a, 0xff-'9' ; maps '0'-'9' onto 0xf6-0xff
|
|
sub 0xff-9 ; maps to 0-9 and carries if not a digit
|
|
ret c ; Error. If it's C, it's also going to be NZ
|
|
; During this routine, we switch between HL and its shadow. On one side,
|
|
; we have HL the string pointer, and on the other side, we have HL the
|
|
; numerical result. We also use EXX to preserve BC, saving us a push.
|
|
exx ; HL as a result
|
|
ld h, 0
|
|
ld l, a ; load first digit in without multiplying
|
|
|
|
.loop:
|
|
exx ; HL as a string pointer
|
|
inc hl
|
|
ld a, (hl)
|
|
exx ; HL as a numerical result
|
|
|
|
; same as other above
|
|
add a, 0xff-'9'
|
|
sub 0xff-9
|
|
jr c, .end
|
|
|
|
ld b, a ; we can now use a for overflow checking
|
|
add hl, hl ; x2
|
|
sbc a, a ; a=0 if no overflow, a=0xFF otherwise
|
|
ld d, h
|
|
ld e, l ; de is x2
|
|
add hl, hl ; x4
|
|
rla
|
|
add hl, hl ; x8
|
|
rla
|
|
add hl, de ; x10
|
|
rla
|
|
ld d, a ; a is zero unless there's an overflow
|
|
ld e, b
|
|
add hl, de
|
|
adc a, a ; same as rla except affects Z
|
|
; Did we oveflow?
|
|
jr z, .loop ; No? continue
|
|
; error, NZ already set
|
|
exx ; HL is now string pointer, restore BC
|
|
; HL points to the char following the last success.
|
|
ret
|
|
|
|
.end:
|
|
push hl ; --> lvl 1, result
|
|
exx ; HL as a string pointer, restore BC
|
|
pop de ; <-- lvl 1, result
|
|
cp a ; ensure Z
|
|
ret
|
|
|
|
.negative:
|
|
inc hl
|
|
call parseDecimal
|
|
ret nz
|
|
push hl ; --> lvl 1
|
|
or a ; clear carry
|
|
ld hl, 0
|
|
sbc hl, de
|
|
ex de, hl
|
|
pop hl ; <-- lvl 1
|
|
xor a ; set Z
|
|
ret
|
|
|
|
; *** Support routines ***
|
|
; 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:
|
|
push bc
|
|
push hl
|
|
; First, figure out string len
|
|
ld bc, 0
|
|
xor a
|
|
cpir
|
|
; C has our length, negative, -1
|
|
ld a, c
|
|
neg
|
|
dec a
|
|
; special case. zero len? we never find anything.
|
|
jr z, .fail
|
|
ld c, a ; C holds our length
|
|
; Let's do something weird: We'll hold HL by the *tail*. Because of our
|
|
; dict structure and because we know our lengths, it's easier to
|
|
; compare starting from the end. Currently, after CPIR, HL points to
|
|
; char after null. Let's adjust
|
|
; Because the compare loop pre-decrements, instead of DECing HL twice,
|
|
; we DEC it once.
|
|
dec hl
|
|
ld de, (CURRENT)
|
|
.inner:
|
|
; DE is a wordref. First step, do our len correspond?
|
|
push hl ; --> lvl 1
|
|
push de ; --> lvl 2
|
|
dec de
|
|
ld a, (de)
|
|
and 0x7f ; remove IMMEDIATE flag
|
|
cp c
|
|
jr nz, .loopend
|
|
; match, let's compare the string then
|
|
dec de \ dec de ; skip prev field. One less because we
|
|
; pre-decrement
|
|
ld b, c ; loop C times
|
|
.loop:
|
|
; pre-decrement for easier Z matching
|
|
dec de
|
|
dec hl
|
|
ld a, (de)
|
|
cp (hl)
|
|
jr nz, .loopend
|
|
djnz .loop
|
|
.loopend:
|
|
; At this point, Z is set if we have a match. In all cases, we want
|
|
; to pop HL and DE
|
|
pop de ; <-- lvl 2
|
|
pop hl ; <-- lvl 1
|
|
jr z, .end ; match? we're done!
|
|
; no match, go to prev and continue
|
|
push hl ; --> lvl 1
|
|
dec de \ dec de \ dec de ; prev field
|
|
push de ; --> lvl 2
|
|
ex de, hl
|
|
call intoHL
|
|
ex de, hl ; DE contains prev offset
|
|
pop hl ; <-- lvl 2
|
|
; HL is prev field's addr
|
|
; Is offset zero?
|
|
ld a, d
|
|
or e
|
|
jr z, .noprev ; no prev entry
|
|
; get absolute addr from offset
|
|
; carry cleared from "or e"
|
|
sbc hl, de
|
|
ex de, hl ; result in DE
|
|
.noprev:
|
|
pop hl ; <-- lvl 1
|
|
jr nz, .inner ; try to match again
|
|
; Z set? end of dict unset Z
|
|
.fail:
|
|
xor a
|
|
inc a
|
|
.end:
|
|
pop hl
|
|
pop bc
|
|
ret
|
|
|
|
; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
|
|
flagsToBC:
|
|
ld bc, 0
|
|
ret z ; equal
|
|
inc bc
|
|
ret m ; >
|
|
; <
|
|
dec bc
|
|
dec bc
|
|
ret
|
|
|
|
; Write DE in (HL), advancing HL by 2.
|
|
DEinHL:
|
|
ld (hl), e
|
|
inc hl
|
|
ld (hl), d
|
|
inc hl
|
|
ret
|
|
|
|
; *** Stack management ***
|
|
; 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. IX always points to RS'
|
|
; Top Of Stack (TOS)
|
|
;
|
|
; 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:
|
|
inc ix
|
|
inc ix
|
|
ld (ix), l
|
|
ld (ix+1), h
|
|
ret
|
|
|
|
; Pop RS' TOS to HL
|
|
popRS:
|
|
ld l, (ix)
|
|
ld h, (ix+1)
|
|
dec ix
|
|
dec ix
|
|
ret
|
|
|
|
popRSIP:
|
|
call popRS
|
|
ld (IP), hl
|
|
ret
|
|
|
|
; Verifies that SP and RS are within bounds. If it's not, call ABORT
|
|
chkRS:
|
|
push ix \ pop hl
|
|
push de ; --> lvl 1
|
|
ld de, RS_ADDR
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
pop de ; <-- lvl 1
|
|
jp c, abortUnderflow
|
|
ret
|
|
|
|
chkPS:
|
|
push hl
|
|
ld hl, (INITIAL_SP)
|
|
; We have the return address for this very call on the stack and
|
|
; protected registers. Let's compensate
|
|
dec hl \ dec hl
|
|
dec hl \ dec hl
|
|
or a ; clear carry
|
|
sbc hl, sp
|
|
pop hl
|
|
ret nc ; (INITIAL_SP) >= SP? good
|
|
jp abortUnderflow
|
|
|
|
; *** Dictionary ***
|
|
; It's important that this part is at the end of the resulting binary.
|
|
; A dictionary entry has this structure:
|
|
; - Xb name. Arbitrary long number of character (but can't be bigger than
|
|
; input buffer, of course). not null-terminated
|
|
; - 2b prev offset
|
|
; - 1b size + IMMEDIATE flag
|
|
; - 2b code pointer
|
|
; - Parameter field (PF)
|
|
;
|
|
; The prev offset is the number of bytes between the prev field and the
|
|
; previous word's code pointer.
|
|
;
|
|
; The size + flag indicate the size of the name field, with the 7th bit
|
|
; being the IMMEDIATE flag.
|
|
;
|
|
; 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
|
|
|
|
; 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
|
|
|
|
; Pop previous IP from Return stack and execute it.
|
|
; ( R:I -- )
|
|
.db "EXIT"
|
|
.dw 0
|
|
.db 4
|
|
EXIT:
|
|
.dw nativeWord
|
|
call popRSIP
|
|
jp next
|
|
|
|
; ( R:I -- )
|
|
.db "QUIT"
|
|
.dw $-EXIT
|
|
.db 4
|
|
QUIT:
|
|
.dw compiledWord
|
|
.dw NUMBER
|
|
.dw 0
|
|
.dw FLAGS_
|
|
.dw STORE
|
|
.dw .private
|
|
.dw INTERPRET
|
|
|
|
.private:
|
|
.dw nativeWord
|
|
ld ix, RS_ADDR
|
|
jp next
|
|
|
|
.db "ABORT"
|
|
.dw $-QUIT
|
|
.db 5
|
|
ABORT:
|
|
.dw compiledWord
|
|
.dw .private
|
|
.dw QUIT
|
|
|
|
.private:
|
|
.dw nativeWord
|
|
; Reinitialize PS
|
|
ld sp, (INITIAL_SP)
|
|
jp next
|
|
|
|
abortUnderflow:
|
|
ld hl, .word
|
|
push hl
|
|
jp EXECUTE+2
|
|
.word:
|
|
.dw compiledWord
|
|
.dw LIT
|
|
.db "stack underfl", 0
|
|
.dw NUMBER
|
|
.dw PRINTPTR
|
|
.dw FETCH
|
|
.dw EXECUTE
|
|
.dw ABORT
|
|
|
|
.db "BYE"
|
|
.dw $-ABORT
|
|
.db 3
|
|
BYE:
|
|
.dw nativeWord
|
|
halt
|
|
|
|
; STABLE ABI
|
|
; Offset: 02aa
|
|
.out $
|
|
; ( c -- )
|
|
.db "EMIT"
|
|
.dw $-BYE
|
|
.db 4
|
|
EMIT:
|
|
.dw compiledWord
|
|
.dw NUMBER
|
|
.dw EMITPTR
|
|
.dw FETCH
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
|
|
|
|
.fill 49
|
|
|
|
.db "C,"
|
|
.dw $-EMIT
|
|
.db 2
|
|
CWR:
|
|
.dw nativeWord
|
|
pop de
|
|
call chkPS
|
|
ld hl, (HERE)
|
|
ld (hl), e
|
|
inc hl
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
|
|
.db ","
|
|
.dw $-CWR
|
|
.db 1
|
|
WR:
|
|
.dw nativeWord
|
|
pop de
|
|
call chkPS
|
|
ld hl, (HERE)
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
|
|
.db "ROUTINE"
|
|
.dw $-WR
|
|
.db 0x87 ; IMMEDIATE
|
|
ROUTINE:
|
|
.dw compiledWord
|
|
.dw WORD
|
|
.dw .private
|
|
.dw EXIT
|
|
|
|
.private:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
ld a, (hl)
|
|
ld de, cellWord
|
|
cp 'C'
|
|
jr z, .end
|
|
ld de, JUMPTBL
|
|
cp 'J'
|
|
jr z, .end
|
|
ld de, JUMPTBL+6
|
|
cp 'V'
|
|
jr z, .end
|
|
ld de, JUMPTBL+9
|
|
cp 'N'
|
|
jr z, .end
|
|
ld de, sysvarWord
|
|
cp 'Y'
|
|
jr z, .end
|
|
ld de, doesWord
|
|
cp 'D'
|
|
jr z, .end
|
|
ld de, LIT
|
|
cp 'S'
|
|
jr z, .end
|
|
ld de, NUMBER
|
|
cp 'M'
|
|
jr z, .end
|
|
ld de, JUMPTBL+12
|
|
cp 'P'
|
|
jr nz, .notgood
|
|
; continue to end on match
|
|
.end:
|
|
; is our slen 1?
|
|
inc hl
|
|
ld a, (hl)
|
|
or a
|
|
jr z, .good
|
|
.notgood:
|
|
ld de, 0
|
|
.good:
|
|
push de
|
|
jp next
|
|
|
|
; ( addr -- )
|
|
.db "EXECUTE"
|
|
.dw $-ROUTINE
|
|
.db 7
|
|
; STABLE ABI
|
|
; Offset: 0388
|
|
.out $
|
|
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!
|
|
|
|
|
|
.fill 22
|
|
.db ":"
|
|
.dw $-EXECUTE
|
|
.db 0x81 ; IMMEDIATE
|
|
DEFINE:
|
|
.dw compiledWord
|
|
.dw ENTRYHEAD
|
|
.dw NUMBER
|
|
.dw compiledWord
|
|
.dw WR
|
|
; BBR branch mark
|
|
.dw .compile
|
|
.dw BBR
|
|
.db 4
|
|
; no need for EXIT, ENDDEF takes care of taking us out
|
|
|
|
.compile:
|
|
.dw compiledWord
|
|
.dw WORD
|
|
.dw FIND_
|
|
.dw NOT
|
|
.dw CSKIP
|
|
.dw FBR
|
|
.db 7
|
|
; Maybe number
|
|
.dw PARSEI
|
|
.dw LITN
|
|
.dw EXIT
|
|
; FBR mark
|
|
.dw DUP
|
|
.dw ISIMMED
|
|
.dw CSKIP
|
|
.dw FBR
|
|
.db 5
|
|
; is immediate. just execute.
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
; FBR mark
|
|
; just a word, write
|
|
.dw WR
|
|
.dw EXIT
|
|
|
|
|
|
|
|
.db "DOES>"
|
|
.dw $-DEFINE
|
|
.db 5
|
|
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 hl, (CURRENT)
|
|
ld de, doesWord
|
|
call DEinHL
|
|
inc hl \ inc hl ; cell variable space
|
|
ld de, (IP)
|
|
call DEinHL
|
|
ld (HERE), hl
|
|
jp EXIT+2
|
|
|
|
|
|
.db "IMMEDIATE"
|
|
.dw $-DOES
|
|
.db 9
|
|
IMMEDIATE:
|
|
.dw nativeWord
|
|
ld hl, (CURRENT)
|
|
dec hl
|
|
set FLAG_IMMED, (hl)
|
|
jp next
|
|
|
|
|
|
.db "IMMED?"
|
|
.dw $-IMMEDIATE
|
|
.db 6
|
|
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"
|
|
.dw $-ISIMMED
|
|
.db 4
|
|
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 "SCPY"
|
|
.dw $-LITN
|
|
.db 4
|
|
SCPY:
|
|
.dw nativeWord
|
|
pop hl
|
|
ld de, (HERE)
|
|
call strcpy
|
|
ld (HERE), de
|
|
jp next
|
|
|
|
|
|
.db "(find)"
|
|
.dw $-SCPY
|
|
.db 6
|
|
; STABLE ABI
|
|
; Offset: 047c
|
|
.out $
|
|
FIND_:
|
|
.dw nativeWord
|
|
pop hl
|
|
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
|
|
|
|
; This is an indirect word that can be redirected through "CINPTR"
|
|
; code: it is replaced in readln.fs.
|
|
.db "C<"
|
|
.dw $-FIND_
|
|
.db 2
|
|
CIN:
|
|
.dw compiledWord
|
|
.dw NUMBER
|
|
.dw CINPTR
|
|
.dw FETCH
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
|
|
|
|
; ( c -- f )
|
|
; 33 CMP 1 + NOT
|
|
; The NOT is to normalize the negative/positive numbers to 1 or 0.
|
|
; Hadn't we wanted to normalize, we'd have written:
|
|
; 32 CMP 1 -
|
|
.db "WS?"
|
|
.dw $-CIN
|
|
.db 3
|
|
ISWS:
|
|
.dw compiledWord
|
|
.dw NUMBER
|
|
.dw 33
|
|
.dw CMP
|
|
.dw NUMBER
|
|
.dw 1
|
|
.dw PLUS
|
|
.dw NOT
|
|
.dw EXIT
|
|
|
|
.db "NOT"
|
|
.dw $-ISWS
|
|
.db 3
|
|
NOT:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
ld a, l
|
|
or h
|
|
ld hl, 0
|
|
jr nz, .skip ; true, keep at 0
|
|
; false, make 1
|
|
inc hl
|
|
.skip:
|
|
push hl
|
|
jp next
|
|
|
|
; ( -- c )
|
|
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
|
|
.db "TOWORD"
|
|
.dw $-NOT
|
|
.db 6
|
|
TOWORD:
|
|
.dw compiledWord
|
|
.dw CIN
|
|
.dw DUP
|
|
.dw ISWS
|
|
.dw CSKIP
|
|
.dw EXIT
|
|
.dw DROP
|
|
.dw TOWORD
|
|
.dw EXIT
|
|
|
|
; Read word from C<, copy to WORDBUF, null-terminate, and return, make
|
|
; HL point to WORDBUF.
|
|
.db "WORD"
|
|
.dw $-TOWORD
|
|
.db 4
|
|
; STABLE ABI
|
|
; Offset: 04f7
|
|
.out $
|
|
WORD:
|
|
.dw compiledWord
|
|
.dw NUMBER ; ( a )
|
|
.dw WORDBUF
|
|
.dw TOWORD ; ( a c )
|
|
; branch mark
|
|
.dw OVER ; ( a c a )
|
|
.dw STORE ; ( a )
|
|
.dw NUMBER ; ( a 1 )
|
|
.dw 1
|
|
.dw PLUS ; ( a+1 )
|
|
.dw CIN ; ( a c )
|
|
.dw DUP ; ( a c c )
|
|
.dw ISWS ; ( a c f )
|
|
.dw CSKIP ; ( a c )
|
|
.dw BBR
|
|
.db 20 ; here - mark
|
|
; at this point, we have ( a WS )
|
|
.dw DROP
|
|
.dw NUMBER
|
|
.dw 0
|
|
.dw SWAP ; ( 0 a )
|
|
.dw STORE ; ()
|
|
.dw NUMBER
|
|
.dw WORDBUF
|
|
.dw EXIT
|
|
|
|
.wcpy:
|
|
.dw nativeWord
|
|
ld de, WORDBUF
|
|
push de ; we already have our result
|
|
.loop:
|
|
ld a, (hl)
|
|
cp ' '+1
|
|
jr c, .loopend
|
|
ld (de), a
|
|
inc hl
|
|
inc de
|
|
jr .loop
|
|
.loopend:
|
|
; null-terminate the string.
|
|
xor a
|
|
ld (de), a
|
|
jp next
|
|
|
|
|
|
.db "(parsed)"
|
|
.dw $-WORD
|
|
.db 8
|
|
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
|
|
|
|
|
|
.fill 41
|
|
|
|
|
|
; Indirect parse caller. Reads PARSEPTR and calls
|
|
PARSEI:
|
|
.dw compiledWord
|
|
.dw PARSEPTR_
|
|
.dw FETCH
|
|
.dw EXECUTE
|
|
.dw EXIT
|
|
|
|
|
|
; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
|
|
; HL points to new (HERE)
|
|
.db "(entry)"
|
|
.dw $-PARSED
|
|
.db 7
|
|
ENTRYHEAD:
|
|
.dw compiledWord
|
|
.dw WORD
|
|
.dw .private
|
|
.dw EXIT
|
|
|
|
.private:
|
|
.dw nativeWord
|
|
pop hl
|
|
ld de, (HERE)
|
|
call strcpy
|
|
; DE point to char after null, rewind.
|
|
dec de
|
|
; B counts the null, adjust
|
|
dec b
|
|
ld a, b
|
|
ex de, hl ; HL points to new HERE
|
|
ld de, (CURRENT)
|
|
push hl ; --> lvl 1
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
ex de, hl
|
|
pop hl ; <-- lvl 1
|
|
call DEinHL
|
|
; Save size
|
|
ld (hl), b
|
|
inc hl
|
|
ld (CURRENT), hl
|
|
ld (HERE), hl
|
|
jp next
|
|
|
|
|
|
; STABLE ABI (every sysvars)
|
|
; Offset: 05ca
|
|
.out $
|
|
.db "HERE"
|
|
.dw $-ENTRYHEAD
|
|
.db 4
|
|
HERE_: ; Caution: conflicts with actual variable name
|
|
.dw sysvarWord
|
|
.dw HERE
|
|
|
|
.db "CURRENT"
|
|
.dw $-HERE_
|
|
.db 7
|
|
CURRENT_:
|
|
.dw sysvarWord
|
|
.dw CURRENT
|
|
|
|
.db "(parse*)"
|
|
.dw $-CURRENT_
|
|
.db 8
|
|
PARSEPTR_:
|
|
.dw sysvarWord
|
|
.dw PARSEPTR
|
|
|
|
.db "FLAGS"
|
|
.dw $-PARSEPTR_
|
|
.db 5
|
|
FLAGS_:
|
|
.dw sysvarWord
|
|
.dw FLAGS
|
|
|
|
.db "SYSVNXT"
|
|
.dw $-FLAGS_
|
|
.db 7
|
|
SYSVNXT_:
|
|
.dw sysvarWord
|
|
.dw SYSVNXT
|
|
|
|
; ( n a -- )
|
|
.db "!"
|
|
.dw $-SYSVNXT_
|
|
.db 1
|
|
; STABLE ABI
|
|
; Offset: 0610
|
|
.out $
|
|
STORE:
|
|
.dw nativeWord
|
|
pop iy
|
|
pop hl
|
|
call chkPS
|
|
ld (iy), l
|
|
ld (iy+1), h
|
|
jp next
|
|
|
|
; ( a -- n )
|
|
.db "@"
|
|
.dw $-STORE
|
|
.db 1
|
|
FETCH:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
call intoHL
|
|
push hl
|
|
jp next
|
|
|
|
; ( a -- )
|
|
.db "DROP"
|
|
.dw $-FETCH
|
|
.db 4
|
|
; STABLE ABI
|
|
DROP:
|
|
.dw nativeWord
|
|
pop hl
|
|
jp next
|
|
|
|
; ( a b -- b a )
|
|
.db "SWAP"
|
|
.dw $-DROP
|
|
.db 4
|
|
SWAP:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
ex (sp), hl
|
|
push hl
|
|
jp next
|
|
|
|
; ( a -- a a )
|
|
.db "DUP"
|
|
.dw $-SWAP
|
|
.db 3
|
|
DUP:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
push hl
|
|
push hl
|
|
jp next
|
|
|
|
; ( a b -- a b a )
|
|
.db "OVER"
|
|
.dw $-DUP
|
|
.db 4
|
|
OVER:
|
|
.dw nativeWord
|
|
pop hl ; B
|
|
pop de ; A
|
|
call chkPS
|
|
push de
|
|
push hl
|
|
push de
|
|
jp next
|
|
|
|
|
|
.fill 31
|
|
|
|
; ( a b -- c ) A + B
|
|
.db "+"
|
|
.dw $-OVER
|
|
.db 1
|
|
PLUS:
|
|
.dw nativeWord
|
|
pop hl
|
|
pop de
|
|
call chkPS
|
|
add hl, de
|
|
push hl
|
|
jp next
|
|
|
|
.fill 18
|
|
|
|
; ( a1 a2 -- b )
|
|
.db "SCMP"
|
|
.dw $-PLUS
|
|
.db 4
|
|
SCMP:
|
|
.dw nativeWord
|
|
pop de
|
|
pop hl
|
|
call chkPS
|
|
call strcmp
|
|
call flagsToBC
|
|
push bc
|
|
jp next
|
|
|
|
; ( n1 n2 -- f )
|
|
.db "CMP"
|
|
.dw $-SCMP
|
|
.db 3
|
|
CMP:
|
|
.dw nativeWord
|
|
pop hl
|
|
pop de
|
|
call chkPS
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
call flagsToBC
|
|
push bc
|
|
jp next
|
|
|
|
; Skip the compword where HL is currently pointing. If it's a regular word,
|
|
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
|
|
; to after null-termination.
|
|
.db "SKIP?"
|
|
.dw $-CMP
|
|
.db 5
|
|
; STABLE ABI
|
|
; Offset: 06ee
|
|
.out $
|
|
CSKIP:
|
|
.dw nativeWord
|
|
pop hl
|
|
call chkPS
|
|
ld a, h
|
|
or l
|
|
jp z, next ; False, do nothing.
|
|
ld hl, (IP)
|
|
ld de, NUMBER
|
|
call .HLPointsDE
|
|
jr z, .isNum
|
|
ld de, FBR
|
|
call .HLPointsDE
|
|
jr z, .isBranch
|
|
ld de, BBR
|
|
call .HLPointsDE
|
|
jr z, .isBranch
|
|
ld de, LIT
|
|
call .HLPointsDE
|
|
jr nz, .isWord
|
|
; We have a literal
|
|
inc hl \ inc hl
|
|
call strskip
|
|
inc hl ; byte after word termination
|
|
jr .end
|
|
.isNum:
|
|
; skip by 4
|
|
inc hl
|
|
; continue to isBranch
|
|
.isBranch:
|
|
; skip by 3
|
|
inc hl
|
|
; continue to isWord
|
|
.isWord:
|
|
; skip by 2
|
|
inc hl \ inc hl
|
|
.end:
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
; Sets Z if (HL) == E and (HL+1) == D
|
|
.HLPointsDE:
|
|
ld a, (hl)
|
|
cp e
|
|
ret nz ; no
|
|
inc hl
|
|
ld a, (hl)
|
|
dec hl
|
|
cp d ; Z has our answer
|
|
ret
|
|
|
|
; 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)"
|
|
.dw $-CSKIP
|
|
.db 5
|
|
; STABLE ABI
|
|
; Offset: 073e
|
|
.out $
|
|
FBR:
|
|
.dw nativeWord
|
|
push de
|
|
ld hl, (IP)
|
|
ld a, (hl)
|
|
call addHL
|
|
ld (IP), hl
|
|
pop de
|
|
jp next
|
|
|
|
.db "(bbr)"
|
|
.dw $-FBR
|
|
.db 5
|
|
; STABLE ABI
|
|
; Offset: 0757
|
|
.out $
|
|
BBR:
|
|
.dw nativeWord
|
|
ld hl, (IP)
|
|
ld d, 0
|
|
ld e, (hl)
|
|
or a ; clear carry
|
|
sbc hl, de
|
|
ld (IP), hl
|
|
jp next
|
|
|
|
; To allow dict binaries to "hook themselves up", we always end such binary
|
|
; with a dummy, *empty* entry. Therefore, we can have a predictable place for
|
|
; getting a prev label.
|
|
.db "_bend"
|
|
.dw $-BBR
|
|
.db 5
|