|
- ; 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
- ; Buffer where WORD copies its read word to.
- .equ WORD_BUFSIZE 0x20
- ; Allocated space for sysvars (see comment above SYSVCNT)
- .equ SYSV_BUFSIZE 0x10
-
- ; *** 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
- .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 0x08-$
- JUMPTBL:
- jp sysvarWord
- jp cellWord
- jp compiledWord
- jp pushRS
- jp popRS
- jp nativeWord
- jp next
- jp chkPS
- ; 24
- NUMBER:
- .dw numberWord
- LIT:
- .dw litWord
- .dw INITIAL_SP
-
- ; *** 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.
- ld sp, 0xfffa
- 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 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, .bootName
- call find
- push de
- jp EXECUTE+2
-
- .parseName:
- .db "(parse)", 0
- .cinName:
- .db "(c<)", 0
- .emitName:
- .db "(emit)", 0
- .keyName:
- .db "KEY", 0
- .bootName:
- .db "BOOT", 0
-
- INTERPRET:
- .dw compiledWord
- .dw LIT
- .db "INTERPRET", 0
- .dw FIND_
- .dw DROP
- .dw EXECUTE
-
- .fill 41
-
- ; *** 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
-
- abortUnderflow:
- ld hl, .name
- call find
- push de
- jp EXECUTE+2
- .name:
- .db "(uflw)", 0
-
- .fill 50
-
- ; STABLE ABI
- ; Offset: 02aa
- .out $
- ; ( c -- )
- .db "EMIT"
- .dw $-QUIT
- .db 4
- EMIT:
- .dw compiledWord
- .dw NUMBER
- .dw EMITPTR
- .dw FETCH
- .dw EXECUTE
- .dw EXIT
-
-
- .fill 71
-
- .db ","
- .dw $-EMIT
- .db 1
- WR:
- .dw nativeWord
- pop de
- call chkPS
- ld hl, (HERE)
- call DEinHL
- ld (HERE), hl
- jp next
-
- .fill 100
-
- ; ( addr -- )
- .db "EXECUTE"
- .dw $-WR
- .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 77
-
- .db "DOES>"
- .dw $-EXECUTE
- .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
-
-
- .fill 51
-
- ; ( n -- )
- .db "LITN"
- .dw $-DOES
- .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 96
-
- .db "JTBL"
- .dw $-PARSED
- .db 4
- JTBL:
- .dw sysvarWord
- .dw JUMPTBL
-
- ; STABLE ABI (every sysvars)
- ; Offset: 05ca
- .out $
- .db "HERE"
- .dw $-JTBL
- .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
|