mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 10:20:55 +11:00
Compare commits
6 Commits
52e6eaafc7
...
cf2f6703bb
Author | SHA1 | Date | |
---|---|---|---|
|
cf2f6703bb | ||
|
966f6df0c5 | ||
|
636407969d | ||
|
d1f572d2ed | ||
|
42abbe75aa | ||
|
6eaabb9bbe |
@ -103,7 +103,7 @@ updatebootstrap: $(ZASMBIN)
|
||||
# words and they write to HERE at initialization.
|
||||
.PHONY: fbootstrap
|
||||
fbootstrap: forth/stage2
|
||||
cat ../forth/dummy.fs ../forth/z80c.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
|
||||
cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
|
17
emul/forth/emul.fs
Normal file
17
emul/forth/emul.fs
Normal file
@ -0,0 +1,17 @@
|
||||
( Implementation fo KEY and EMIT in the emulator
|
||||
stdio port is 0
|
||||
)
|
||||
|
||||
CODE (emit)
|
||||
HL POPqq,
|
||||
chkPS,
|
||||
A L LDrr,
|
||||
0 OUTnA,
|
||||
;CODE
|
||||
|
||||
CODE KEY
|
||||
0 INAn,
|
||||
H 0 LDrn,
|
||||
L A LDrr,
|
||||
HL PUSHqq,
|
||||
;CODE
|
@ -29,7 +29,7 @@ trouble of compiling defs to binary.
|
||||
|
||||
//#define DEBUG
|
||||
// in sync with glue.asm
|
||||
#define RAMSTART 0x900
|
||||
#define RAMSTART 0x890
|
||||
#define STDIO_PORT 0x00
|
||||
// To know which part of RAM to dump, we listen to port 2, which at the end of
|
||||
// its compilation process, spits its HERE addr to port 2 (MSB first)
|
||||
|
@ -1,5 +1,3 @@
|
||||
jp init
|
||||
|
||||
.inc "stagec.asm"
|
||||
.inc "forth.asm"
|
||||
|
||||
|
@ -1,5 +1,3 @@
|
||||
jp init
|
||||
|
||||
.inc "stagec.asm"
|
||||
.inc "forth.asm"
|
||||
|
||||
|
@ -2,23 +2,3 @@
|
||||
.equ HERE_INITIAL CODE_END ; override
|
||||
.equ LATEST CODE_END ; override
|
||||
.equ STDIO_PORT 0x00
|
||||
|
||||
init:
|
||||
di
|
||||
; setup stack
|
||||
ld sp, 0xffff
|
||||
call forthMain
|
||||
halt
|
||||
|
||||
emulGetC:
|
||||
; Blocks until a char is returned
|
||||
in a, (STDIO_PORT)
|
||||
cp a ; ensure Z
|
||||
ret
|
||||
|
||||
emulPutC:
|
||||
out (STDIO_PORT), a
|
||||
ret
|
||||
|
||||
.equ GETC emulGetC
|
||||
.equ PUTC emulPutC
|
||||
|
Binary file not shown.
@ -1,7 +1,7 @@
|
||||
( When building a compiled dict, always include this unit at
|
||||
the end of it so that Forth knows how to hook LATEST into
|
||||
it )
|
||||
(entry) _______
|
||||
(entry) _
|
||||
|
||||
( After each dummy word like this, we poke IO port 2 with our
|
||||
current HERE value. The staging executable needs it to know
|
||||
|
452
forth/forth.asm
452
forth/forth.asm
@ -26,19 +26,14 @@
|
||||
.equ RS_ADDR 0xf000
|
||||
; Number of bytes we keep as a padding between HERE and the scratchpad
|
||||
.equ PADDING 0x20
|
||||
; Max length of dict entry names
|
||||
.equ NAMELEN 7
|
||||
; Offset of the code link relative to the beginning of the word
|
||||
.equ CODELINK_OFFSET NAMELEN+3
|
||||
; Buffer where WORD copies its read word to. It's significantly larger than
|
||||
; NAMELEN, but who knows, in a comment, we might have a very long word...
|
||||
; 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 0
|
||||
.equ FLAG_IMMED 7
|
||||
|
||||
; *** Variables ***
|
||||
.equ INITIAL_SP RAMSTART
|
||||
@ -61,6 +56,8 @@
|
||||
; 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
|
||||
@ -106,6 +103,8 @@
|
||||
; *** 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 0x17-$
|
||||
JUMPTBL:
|
||||
jp nativeWord
|
||||
@ -131,16 +130,21 @@ forthMain:
|
||||
ld hl, HERE_INITIAL
|
||||
ld (HERE), hl
|
||||
; Set up PARSEPTR
|
||||
ld hl, PARSE-CODELINK_OFFSET
|
||||
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 de, KEY
|
||||
ld hl, .keyName
|
||||
call find
|
||||
.skip:
|
||||
ld (CINPTR), de
|
||||
; Set up SYSVNXT
|
||||
@ -150,8 +154,14 @@ forthMain:
|
||||
push hl
|
||||
jp EXECUTE+2
|
||||
|
||||
.parseName:
|
||||
.db "(parse)", 0
|
||||
.cinName:
|
||||
.db "(c<)", 0
|
||||
.emitName:
|
||||
.db "(emit)", 0
|
||||
.keyName:
|
||||
.db "KEY", 0
|
||||
|
||||
BEGIN:
|
||||
.dw compiledWord
|
||||
@ -170,23 +180,25 @@ INTERPRET:
|
||||
.dw FIND_
|
||||
.dw CSKIP
|
||||
.dw FBR
|
||||
.db 18
|
||||
.db 22
|
||||
; It's a word, execute it
|
||||
; For now, we only have one flag, let's take advantage of
|
||||
; this to keep code simple.
|
||||
.dw ONE ; Bit 0 on
|
||||
.dw NUMBER ; Bit 0 on
|
||||
.dw 1
|
||||
.dw FLAGS_
|
||||
.dw STORE
|
||||
.dw EXECUTE
|
||||
.dw ZERO ; Bit 0 off
|
||||
.dw NUMBER ; Bit 0 off
|
||||
.dw 0
|
||||
.dw FLAGS_
|
||||
.dw STORE
|
||||
.dw BBR
|
||||
.db 25
|
||||
.db 29
|
||||
; FBR mark, try number
|
||||
.dw PARSEI
|
||||
.dw BBR
|
||||
.db 30
|
||||
.db 34
|
||||
; infinite loop
|
||||
|
||||
; *** Collapse OS lib copy ***
|
||||
@ -221,13 +233,17 @@ addHL:
|
||||
; 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, strcpy
|
||||
jr nz, .loop
|
||||
ret
|
||||
|
||||
; Compares strings pointed to by HL and DE until one of them hits its null char.
|
||||
@ -254,38 +270,6 @@ strcmp:
|
||||
; early, set otherwise)
|
||||
ret
|
||||
|
||||
; Compares strings pointed to by HL and DE up to NAMELEN count of characters. If
|
||||
; equal, Z is set. If not equal, Z is reset.
|
||||
strncmp:
|
||||
push bc
|
||||
push hl
|
||||
push de
|
||||
|
||||
ld b, NAMELEN
|
||||
.loop:
|
||||
ld a, (de)
|
||||
cp (hl)
|
||||
jr nz, .end ; not equal? break early. NZ is carried out
|
||||
; to the called
|
||||
or a ; If our chars are null, stop the cmp
|
||||
jr z, .end ; The positive result will be carried to the
|
||||
; caller
|
||||
inc hl
|
||||
inc de
|
||||
djnz .loop
|
||||
; We went through all chars with success, but our current Z flag is
|
||||
; unset because of the cp 0. Let's do a dummy CP to set the Z flag.
|
||||
cp a
|
||||
|
||||
.end:
|
||||
pop de
|
||||
pop hl
|
||||
pop bc
|
||||
; 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
|
||||
@ -370,51 +354,82 @@ parseDecimal:
|
||||
; point to that entry.
|
||||
; Z if found, NZ if not.
|
||||
find:
|
||||
push hl
|
||||
push bc
|
||||
ld de, (CURRENT)
|
||||
ld bc, CODELINK_OFFSET
|
||||
.inner:
|
||||
; DE is a wordref, let's go to beginning of struct
|
||||
push de ; --> lvl 1
|
||||
or a ; clear carry
|
||||
ex de, hl
|
||||
sbc hl, bc
|
||||
ex de, hl ; We're good, DE points to word name
|
||||
call strncmp
|
||||
pop de ; <-- lvl 1, return to wordref
|
||||
jr z, .end ; found
|
||||
push hl ; .prev destroys HL
|
||||
call .prev
|
||||
pop hl
|
||||
jr nz, .inner
|
||||
; Z set? end of dict unset Z
|
||||
push hl
|
||||
; First, figure out string len
|
||||
ld bc, 0
|
||||
xor a
|
||||
inc a
|
||||
.end:
|
||||
pop bc
|
||||
pop hl
|
||||
ret
|
||||
|
||||
; For DE being a wordref, move DE to the previous wordref.
|
||||
; Z is set if DE point to 0 (no entry). NZ if not.
|
||||
.prev:
|
||||
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 1
|
||||
push de ; --> lvl 2
|
||||
ex de, hl
|
||||
call intoHL
|
||||
ex de, hl ; DE contains prev offset
|
||||
pop hl ; <-- lvl 1
|
||||
pop hl ; <-- lvl 2
|
||||
; HL is prev field's addr
|
||||
; Is offset zero?
|
||||
ld a, d
|
||||
or e
|
||||
ret z ; no prev entry
|
||||
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
|
||||
ret ; NZ set from SBC
|
||||
.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:
|
||||
@ -495,15 +510,19 @@ chkPS:
|
||||
; *** Dictionary ***
|
||||
; It's important that this part is at the end of the resulting binary.
|
||||
; A dictionary entry has this structure:
|
||||
; - 7b name (zero-padded)
|
||||
; - Xb name. Arbitrary long number of character (but can't be bigger than
|
||||
; input buffer, of course). not null-terminated
|
||||
; - 2b prev offset
|
||||
; - 1b flags (bit 0: IMMEDIATE)
|
||||
; - 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".
|
||||
@ -611,9 +630,8 @@ LIT:
|
||||
; Pop previous IP from Return stack and execute it.
|
||||
; ( R:I -- )
|
||||
.db "EXIT"
|
||||
.fill 3
|
||||
.dw 0
|
||||
.db 0
|
||||
.db 4
|
||||
EXIT:
|
||||
.dw nativeWord
|
||||
call popRSIP
|
||||
@ -621,12 +639,12 @@ EXIT:
|
||||
|
||||
; ( R:I -- )
|
||||
.db "QUIT"
|
||||
.fill 3
|
||||
.dw $-EXIT
|
||||
.db 0
|
||||
.db 4
|
||||
QUIT:
|
||||
.dw compiledWord
|
||||
.dw ZERO
|
||||
.dw NUMBER
|
||||
.dw 0
|
||||
.dw FLAGS_
|
||||
.dw STORE
|
||||
.dw .private
|
||||
@ -638,9 +656,8 @@ QUIT:
|
||||
jp next
|
||||
|
||||
.db "ABORT"
|
||||
.fill 2
|
||||
.dw $-QUIT
|
||||
.db 0
|
||||
.db 5
|
||||
ABORT:
|
||||
.dw compiledWord
|
||||
.dw .private
|
||||
@ -664,51 +681,63 @@ abortUnderflow:
|
||||
.dw ABORT
|
||||
|
||||
.db "BYE"
|
||||
.fill 4
|
||||
.dw $-ABORT
|
||||
.db 0
|
||||
.db 3
|
||||
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
|
||||
halt
|
||||
|
||||
; ( c -- )
|
||||
.db "EMIT"
|
||||
.fill 3
|
||||
.dw $-BYE
|
||||
.db 0
|
||||
.db 4
|
||||
EMIT:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
ld a, l
|
||||
call PUTC
|
||||
jp next
|
||||
.dw compiledWord
|
||||
.dw NUMBER
|
||||
.dw EMITPTR
|
||||
.dw FETCH
|
||||
.dw EXECUTE
|
||||
.dw EXIT
|
||||
|
||||
|
||||
.db "(print)"
|
||||
.dw $-EMIT
|
||||
.db 0
|
||||
.db 7
|
||||
PRINT:
|
||||
.dw compiledWord ; a
|
||||
; BBR mark
|
||||
.dw DUP ; a a
|
||||
.dw .getc ; a c
|
||||
.dw DUP ; a c f
|
||||
.dw CSKIP ; a c
|
||||
; zero, end of string
|
||||
.dw FBR
|
||||
.db 12
|
||||
.dw EMIT ; a
|
||||
.dw NUMBER ; a 1
|
||||
.dw 1
|
||||
.dw PLUS ; a+1
|
||||
.dw BBR
|
||||
.db 21
|
||||
; FBR mark
|
||||
.dw DROP
|
||||
.dw DROP
|
||||
.dw EXIT
|
||||
|
||||
; Yes, very much like C@, but it has already been Forth-ified...
|
||||
.getc:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
.loop:
|
||||
ld a, (hl) ; load character to send
|
||||
or a ; is it zero?
|
||||
jp z, next ; if yes, we're finished
|
||||
call PUTC
|
||||
inc hl
|
||||
jr .loop
|
||||
ld l, (hl)
|
||||
ld h, 0
|
||||
push hl
|
||||
jp next
|
||||
|
||||
|
||||
.db "C,"
|
||||
.fill 5
|
||||
.dw $-PRINT
|
||||
.db 0
|
||||
.db 2
|
||||
CWR:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
@ -721,9 +750,8 @@ CWR:
|
||||
|
||||
|
||||
.db ","
|
||||
.fill 6
|
||||
.dw $-CWR
|
||||
.db 0
|
||||
.db 1
|
||||
WR:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
@ -736,7 +764,7 @@ WR:
|
||||
|
||||
.db "ROUTINE"
|
||||
.dw $-WR
|
||||
.db 1 ; IMMEDIATE
|
||||
.db 0x87 ; IMMEDIATE
|
||||
ROUTINE:
|
||||
.dw compiledWord
|
||||
.dw WORD
|
||||
@ -791,7 +819,7 @@ ROUTINE:
|
||||
; ( addr -- )
|
||||
.db "EXECUTE"
|
||||
.dw $-ROUTINE
|
||||
.db 0
|
||||
.db 7
|
||||
EXECUTE:
|
||||
.dw nativeWord
|
||||
pop iy ; is a wordref
|
||||
@ -806,9 +834,8 @@ EXECUTE:
|
||||
|
||||
|
||||
.db ";"
|
||||
.fill 6
|
||||
.dw $-EXECUTE
|
||||
.db 1 ; IMMEDIATE
|
||||
.db 0x81 ; IMMEDIATE
|
||||
ENDDEF:
|
||||
.dw compiledWord
|
||||
.dw NUMBER
|
||||
@ -821,9 +848,8 @@ ENDDEF:
|
||||
.dw EXIT
|
||||
|
||||
.db ":"
|
||||
.fill 6
|
||||
.dw $-ENDDEF
|
||||
.db 1 ; IMMEDIATE
|
||||
.db 0x81 ; IMMEDIATE
|
||||
DEFINE:
|
||||
.dw compiledWord
|
||||
.dw ENTRYHEAD
|
||||
@ -865,9 +891,8 @@ DEFINE:
|
||||
|
||||
|
||||
.db "DOES>"
|
||||
.fill 2
|
||||
.dw $-DEFINE
|
||||
.db 0
|
||||
.db 5
|
||||
DOES:
|
||||
.dw nativeWord
|
||||
; We run this when we're in an entry creation context. Many things we
|
||||
@ -886,9 +911,9 @@ DOES:
|
||||
jp EXIT+2
|
||||
|
||||
|
||||
.db "IMMEDIA"
|
||||
.db "IMMEDIATE"
|
||||
.dw $-DOES
|
||||
.db 0
|
||||
.db 9
|
||||
IMMEDIATE:
|
||||
.dw nativeWord
|
||||
ld hl, (CURRENT)
|
||||
@ -898,9 +923,8 @@ IMMEDIATE:
|
||||
|
||||
|
||||
.db "IMMED?"
|
||||
.fill 1
|
||||
.dw $-IMMEDIATE
|
||||
.db 0
|
||||
.db 6
|
||||
ISIMMED:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -916,9 +940,8 @@ ISIMMED:
|
||||
|
||||
; ( n -- )
|
||||
.db "LITN"
|
||||
.fill 3
|
||||
.dw $-ISIMMED
|
||||
.db 0
|
||||
.db 4
|
||||
LITN:
|
||||
.dw nativeWord
|
||||
ld hl, (HERE)
|
||||
@ -931,9 +954,8 @@ LITN:
|
||||
jp next
|
||||
|
||||
.db "SCPY"
|
||||
.fill 3
|
||||
.dw $-LITN
|
||||
.db 0
|
||||
.db 4
|
||||
SCPY:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -944,9 +966,8 @@ SCPY:
|
||||
|
||||
|
||||
.db "(find)"
|
||||
.fill 1
|
||||
.dw $-SCPY
|
||||
.db 0
|
||||
.db 6
|
||||
FIND_:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -963,25 +984,11 @@ FIND_:
|
||||
push de
|
||||
jp next
|
||||
|
||||
; ( -- c )
|
||||
.db "KEY"
|
||||
.fill 4
|
||||
.dw $-FIND_
|
||||
.db 0
|
||||
KEY:
|
||||
.dw nativeWord
|
||||
call GETC
|
||||
ld h, 0
|
||||
ld l, a
|
||||
push hl
|
||||
jp next
|
||||
|
||||
; This is an indirect word that can be redirected through "CINPTR"
|
||||
; code: it is replaced in readln.fs.
|
||||
.db "C<"
|
||||
.fill 5
|
||||
.dw $-KEY
|
||||
.db 0
|
||||
.dw $-FIND_
|
||||
.db 2
|
||||
CIN:
|
||||
.dw compiledWord
|
||||
.dw NUMBER
|
||||
@ -997,23 +1004,22 @@ CIN:
|
||||
; Hadn't we wanted to normalize, we'd have written:
|
||||
; 32 CMP 1 -
|
||||
.db "WS?"
|
||||
.fill 4
|
||||
.dw $-CIN
|
||||
.db 0
|
||||
.db 3
|
||||
ISWS:
|
||||
.dw compiledWord
|
||||
.dw NUMBER
|
||||
.dw 33
|
||||
.dw CMP
|
||||
.dw ONE
|
||||
.dw NUMBER
|
||||
.dw 1
|
||||
.dw PLUS
|
||||
.dw NOT
|
||||
.dw EXIT
|
||||
|
||||
.db "NOT"
|
||||
.fill 4
|
||||
.dw $-ISWS
|
||||
.db 0
|
||||
.db 3
|
||||
NOT:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1031,9 +1037,8 @@ NOT:
|
||||
; ( -- c )
|
||||
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
|
||||
.db "TOWORD"
|
||||
.fill 1
|
||||
.dw $-NOT
|
||||
.db 0
|
||||
.db 6
|
||||
TOWORD:
|
||||
.dw compiledWord
|
||||
.dw CIN
|
||||
@ -1048,9 +1053,8 @@ TOWORD:
|
||||
; Read word from C<, copy to WORDBUF, null-terminate, and return, make
|
||||
; HL point to WORDBUF.
|
||||
.db "WORD"
|
||||
.fill 3
|
||||
.dw $-TOWORD
|
||||
.db 0
|
||||
.db 4
|
||||
WORD:
|
||||
.dw compiledWord
|
||||
.dw NUMBER ; ( a )
|
||||
@ -1059,17 +1063,19 @@ WORD:
|
||||
; branch mark
|
||||
.dw OVER ; ( a c a )
|
||||
.dw STORE ; ( a )
|
||||
.dw ONE ; ( a 1 )
|
||||
.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 18 ; here - mark
|
||||
.db 20 ; here - mark
|
||||
; at this point, we have ( a WS )
|
||||
.dw DROP
|
||||
.dw ZERO
|
||||
.dw NUMBER
|
||||
.dw 0
|
||||
.dw SWAP ; ( 0 a )
|
||||
.dw STORE ; ()
|
||||
.dw NUMBER
|
||||
@ -1095,9 +1101,9 @@ WORD:
|
||||
jp next
|
||||
|
||||
|
||||
.db "(parsed"
|
||||
.db "(parsed)"
|
||||
.dw $-WORD
|
||||
.db 0
|
||||
.db 8
|
||||
PARSED:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1118,7 +1124,7 @@ PARSED:
|
||||
|
||||
.db "(parse)"
|
||||
.dw $-PARSED
|
||||
.db 0
|
||||
.db 7
|
||||
PARSE:
|
||||
.dw compiledWord
|
||||
.dw PARSED
|
||||
@ -1148,7 +1154,7 @@ PARSEI:
|
||||
; HL points to new (HERE)
|
||||
.db "(entry)"
|
||||
.dw $-PARSE
|
||||
.db 0
|
||||
.db 7
|
||||
ENTRYHEAD:
|
||||
.dw compiledWord
|
||||
.dw WORD
|
||||
@ -1160,19 +1166,21 @@ ENTRYHEAD:
|
||||
pop hl
|
||||
ld de, (HERE)
|
||||
call strcpy
|
||||
ld hl, (HERE)
|
||||
; 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)
|
||||
ld a, NAMELEN
|
||||
call addHL
|
||||
push hl ; --> lvl 1
|
||||
or a ; clear carry
|
||||
sbc hl, de
|
||||
ex de, hl
|
||||
pop hl ; <-- lvl 1
|
||||
call DEinHL
|
||||
; Set word flags: not IMMED, so it's 0
|
||||
xor a
|
||||
ld (hl), a
|
||||
; Save size
|
||||
ld (hl), b
|
||||
inc hl
|
||||
ld (CURRENT), hl
|
||||
ld (HERE), hl
|
||||
@ -1180,47 +1188,44 @@ ENTRYHEAD:
|
||||
|
||||
|
||||
.db "HERE"
|
||||
.fill 3
|
||||
.dw $-ENTRYHEAD
|
||||
.db 0
|
||||
.db 4
|
||||
HERE_: ; Caution: conflicts with actual variable name
|
||||
.dw sysvarWord
|
||||
.dw HERE
|
||||
|
||||
.db "CURRENT"
|
||||
.dw $-HERE_
|
||||
.db 0
|
||||
.db 7
|
||||
CURRENT_:
|
||||
.dw sysvarWord
|
||||
.dw CURRENT
|
||||
|
||||
.db "(parse*"
|
||||
.db "(parse*)"
|
||||
.dw $-CURRENT_
|
||||
.db 0
|
||||
.db 8
|
||||
PARSEPTR_:
|
||||
.dw sysvarWord
|
||||
.dw PARSEPTR
|
||||
|
||||
.db "FLAGS"
|
||||
.fill 2
|
||||
.dw $-PARSEPTR_
|
||||
.db 0
|
||||
.db 5
|
||||
FLAGS_:
|
||||
.dw sysvarWord
|
||||
.dw FLAGS
|
||||
|
||||
.db "SYSVNXT"
|
||||
.dw $-FLAGS_
|
||||
.db 0
|
||||
.db 7
|
||||
SYSVNXT_:
|
||||
.dw sysvarWord
|
||||
.dw SYSVNXT
|
||||
|
||||
; ( n a -- )
|
||||
.db "!"
|
||||
.fill 6
|
||||
.dw $-SYSVNXT_
|
||||
.db 0
|
||||
.db 1
|
||||
STORE:
|
||||
.dw nativeWord
|
||||
pop iy
|
||||
@ -1232,9 +1237,8 @@ STORE:
|
||||
|
||||
; ( a -- n )
|
||||
.db "@"
|
||||
.fill 6
|
||||
.dw $-STORE
|
||||
.db 0
|
||||
.db 1
|
||||
FETCH:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1245,9 +1249,8 @@ FETCH:
|
||||
|
||||
; ( a -- )
|
||||
.db "DROP"
|
||||
.fill 3
|
||||
.dw $-FETCH
|
||||
.db 0
|
||||
.db 4
|
||||
DROP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1255,9 +1258,8 @@ DROP:
|
||||
|
||||
; ( a b -- b a )
|
||||
.db "SWAP"
|
||||
.fill 3
|
||||
.dw $-DROP
|
||||
.db 0
|
||||
.db 4
|
||||
SWAP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1268,9 +1270,8 @@ SWAP:
|
||||
|
||||
; ( a -- a a )
|
||||
.db "DUP"
|
||||
.fill 4
|
||||
.dw $-SWAP
|
||||
.db 0
|
||||
.db 3
|
||||
DUP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1281,9 +1282,8 @@ DUP:
|
||||
|
||||
; ( a b -- a b a )
|
||||
.db "OVER"
|
||||
.fill 3
|
||||
.dw $-DUP
|
||||
.db 0
|
||||
.db 4
|
||||
OVER:
|
||||
.dw nativeWord
|
||||
pop hl ; B
|
||||
@ -1295,9 +1295,8 @@ OVER:
|
||||
jp next
|
||||
|
||||
.db ">R"
|
||||
.fill 5
|
||||
.dw $-OVER
|
||||
.db 0
|
||||
.db 2
|
||||
P2R:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1306,9 +1305,8 @@ P2R:
|
||||
jp next
|
||||
|
||||
.db "R>"
|
||||
.fill 5
|
||||
.dw $-P2R
|
||||
.db 0
|
||||
.db 2
|
||||
R2P:
|
||||
.dw nativeWord
|
||||
call popRS
|
||||
@ -1316,9 +1314,8 @@ R2P:
|
||||
jp next
|
||||
|
||||
.db "I"
|
||||
.fill 6
|
||||
.dw $-R2P
|
||||
.db 0
|
||||
.db 1
|
||||
I:
|
||||
.dw nativeWord
|
||||
ld l, (ix)
|
||||
@ -1327,9 +1324,8 @@ I:
|
||||
jp next
|
||||
|
||||
.db "I'"
|
||||
.fill 5
|
||||
.dw $-I
|
||||
.db 0
|
||||
.db 2
|
||||
IPRIME:
|
||||
.dw nativeWord
|
||||
ld l, (ix-2)
|
||||
@ -1338,9 +1334,8 @@ IPRIME:
|
||||
jp next
|
||||
|
||||
.db "J"
|
||||
.fill 6
|
||||
.dw $-IPRIME
|
||||
.db 0
|
||||
.db 1
|
||||
J:
|
||||
.dw nativeWord
|
||||
ld l, (ix-4)
|
||||
@ -1350,9 +1345,8 @@ J:
|
||||
|
||||
; ( a b -- c ) A + B
|
||||
.db "+"
|
||||
.fill 6
|
||||
.dw $-J
|
||||
.db 0
|
||||
.db 1
|
||||
PLUS:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1364,9 +1358,8 @@ PLUS:
|
||||
|
||||
; ( a b -- c ) A - B
|
||||
.db "-"
|
||||
.fill 6
|
||||
.dw $-PLUS
|
||||
.db 0
|
||||
.db 1
|
||||
MINUS:
|
||||
.dw nativeWord
|
||||
pop de ; B
|
||||
@ -1379,9 +1372,8 @@ MINUS:
|
||||
|
||||
; ( a b -- c ) A * B
|
||||
.db "*"
|
||||
.fill 6
|
||||
.dw $-MINUS
|
||||
.db 0
|
||||
.db 1
|
||||
MULT:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
@ -1404,36 +1396,10 @@ MULT:
|
||||
push hl
|
||||
jp next
|
||||
|
||||
|
||||
; It might look peculiar to have specific words for "0" and "1", but although
|
||||
; it slightly beefs ups the ASM part of the binary, this one-byte-save-per-use
|
||||
; really adds up when we compare total size.
|
||||
|
||||
.db "0"
|
||||
.fill 6
|
||||
.dw $-MULT
|
||||
.db 0
|
||||
ZERO:
|
||||
.dw nativeWord
|
||||
ld hl, 0
|
||||
push hl
|
||||
jp next
|
||||
|
||||
.db "1"
|
||||
.fill 6
|
||||
.dw $-ZERO
|
||||
.db 0
|
||||
ONE:
|
||||
.dw nativeWord
|
||||
ld hl, 1
|
||||
push hl
|
||||
jp next
|
||||
|
||||
; ( a1 a2 -- b )
|
||||
.db "SCMP"
|
||||
.fill 3
|
||||
.dw $-ONE
|
||||
.db 0
|
||||
.dw $-MULT
|
||||
.db 4
|
||||
SCMP:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
@ -1446,9 +1412,8 @@ SCMP:
|
||||
|
||||
; ( n1 n2 -- f )
|
||||
.db "CMP"
|
||||
.fill 4
|
||||
.dw $-SCMP
|
||||
.db 0
|
||||
.db 3
|
||||
CMP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1464,9 +1429,8 @@ CMP:
|
||||
; 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?"
|
||||
.fill 2
|
||||
.dw $-CMP
|
||||
.db 0
|
||||
.db 5
|
||||
CSKIP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
@ -1522,9 +1486,8 @@ CSKIP:
|
||||
; 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
|
||||
.db 5
|
||||
FBR:
|
||||
.dw nativeWord
|
||||
push de
|
||||
@ -1536,9 +1499,8 @@ FBR:
|
||||
jp next
|
||||
|
||||
.db "(bbr)"
|
||||
.fill 2
|
||||
.dw $-FBR
|
||||
.db 0
|
||||
.db 5
|
||||
BBR:
|
||||
.dw nativeWord
|
||||
ld hl, (IP)
|
||||
@ -1552,7 +1514,5 @@ BBR:
|
||||
; 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 "_______"
|
||||
.dw $-BBR
|
||||
.db 0
|
||||
|
@ -61,6 +61,7 @@
|
||||
0xa0 OP1r0 ANDr,
|
||||
0xb0 OP1r0 ORr,
|
||||
0xa8 OP1r0 XORr,
|
||||
0xb8 OP1r0 CPr,
|
||||
|
||||
( qq -- also works for ss )
|
||||
: OP1qq
|
||||
@ -93,7 +94,7 @@
|
||||
DOES>
|
||||
C@ A, A,
|
||||
;
|
||||
0xd3 OP2n OUTAn,
|
||||
0xd3 OP2n OUTnA,
|
||||
0xdb OP2n INAn,
|
||||
|
||||
( r n -- )
|
||||
|
@ -17,6 +17,9 @@
|
||||
These restrictions are temporary, I'll figure something out
|
||||
so that we can end up fully bootstrap Forth from within
|
||||
itself.
|
||||
|
||||
Oh, also: KEY and EMIT are not defined here. There're
|
||||
expected to be defined in platform-specific code.
|
||||
)
|
||||
|
||||
( a b c -- b c a )
|
||||
|
Loading…
Reference in New Issue
Block a user