1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-02 14:30:55 +11:00

Compare commits

...

9 Commits

Author SHA1 Message Date
Virgil Dupras
a8e573c84a forth: add bin dict compilation stage!
Big one.

This allows us to write higher order words directly in Forth, which is much
more convenient than writing post-immediate (see "NOT" structure in diff if
you want to see what I mean) structures in ASM.

These structures can then be written to ROM (rather than loaded in RAM for
definitions loaded at run-time).

That's quite a bit of tooling that was added, 2 compilations stages, but I
think it's well worth it.
2020-03-12 00:14:44 -04:00
Virgil Dupras
f89e7bd503 forth: add words "C@" and "C!" 2020-03-11 22:11:54 -04:00
Virgil Dupras
80f63cd185 forth: add words "2DUP", "2SWAP", "2OVER" 2020-03-11 21:58:16 -04:00
Virgil Dupras
d8542f7cf7 forth: fix "NOT"
Ouh, I need a solution here...
2020-03-11 19:59:10 -04:00
Virgil Dupras
ea5f33558a forth: make branching offsets 1 byte
Those bytes, those precious bytes!
2020-03-11 19:52:49 -04:00
Virgil Dupras
abdf2c8adc emul/forth: allow running commands from file 2020-03-11 19:03:47 -04:00
Virgil Dupras
3996f0c825 forth: fix IF/THEN/ELSE in colon defs 2020-03-11 17:53:27 -04:00
Virgil Dupras
02b56c547a forth: make branching cells store relative offsets
This should help with fixing IF/THEN/ELSE in colon defs.
2020-03-11 16:46:25 -04:00
Virgil Dupras
6757c097ea forth: change the whole execution model again
Things are better now, but immediates inside colons are broken. However,
IF/THEN/ELSE are now immediates and it's much cleaner this way. Still, this
commit has too much stuff in it, I need to commit, I don't want to lose this
step.
2020-03-10 21:37:06 -04:00
12 changed files with 555 additions and 347 deletions

9
apps/forth/core.fth Normal file
View File

@ -0,0 +1,9 @@
: ? @ . ;
: +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE HERE @ ! DOES> @ ;
: NOT IF 0 ELSE 1 THEN ;
: = CMP NOT ;
: < CMP 0 1 - = ;
: > CMP 1 = ;

View File

@ -51,69 +51,40 @@ doesWord:
push hl \ pop iy
jr compiledWord
; The IF word checks the stack for zero. If it's non-zero, it does nothing and
; allow compiledWord to continue.
; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
; it's a ELSE or THEN, the same thing happens: we resume execution after the
; ELSE/THEN. If it's a EXIT, we simply execute it.
ifWord:
; This word 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.
branchWord:
push de
ld l, (ix)
ld h, (ix+1)
ld a, (hl)
call addHL
ld (ix), l
ld (ix+1), h
pop de
jp exit
BRANCH:
.dw branchWord
; Conditional branch, only branch if TOS is zero
cbranchWord:
pop hl
ld a, h
or l
jp nz, exit ; non-zero, continue
; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
; If a ELSE word is executed, it means that the preceding IF had a non-zero
; condition and continued execution. This means that upon encountering an ELSE,
; we must search for a THEN or an EXIT.
; To simplify implementation and share code with ifWord, we also match ELSE,
; which is only possible in malformed construct. Therefore "IF ELSE ELSE" is
; valid and interpreted as "IF ELSE THEN".
elseWord:
; to save processing, we test EXIT, ELSE and THEN in the order they
; appear, address-wise. This way, we don't need to push/pop HL: we can
; SUB the difference between the words and check for zeroes.
call popRS
; We need to save that IP somewhere. Let it be BC
ld b, h
ld c, l
.loop:
; Whether there's a match or not, we will resume the operation at IP+2,
; which means that we have to increase BC anyways. Let's do it now.
inc bc \ inc bc
call intoHL
or a ; clear carry
ld de, EXIT
sbc hl, de
jp z, exit
; Not EXIT, let's continue with ELSE. No carry possible because EXIT
; is first word. No need to clear.
ld de, ELSE-EXIT
sbc hl, de
jr c, .nomatch ; A word between EXIT and ELSE. No match.
jr z, .match ; We have a ELSE
; Let's try with THEN. Again, no carry possible, C cond was handled.
ld de, THEN-ELSE
sbc hl, de
jr z, .match ; We have a THEN
.nomatch:
; Nothing matched, which means that we need to continue looking.
; BC is already IP+2
ld h, b
ld l, c
jr .loop
.match:
; Matched a ELSE or a THEN, which means we need to continue executing
; word from IP+2, which is already in BC.
push bc \ pop iy
jp compiledWord
; This word does nothing. It's never going to be executed unless the wordlist
; is misconstructed.
thenWord:
jr z, branchWord
; skip next byte in RS
ld l, (ix)
ld h, (ix+1)
inc hl
ld (ix), l
ld (ix+1), h
jp exit
CBRANCH:
.dw cbranchWord
; 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
@ -121,12 +92,14 @@ thenWord:
; it to the Parameter stack and then push an increase Interpreter Pointer back
; to RS.
numberWord:
call popRS
ld l, (ix)
ld h, (ix+1)
ld e, (hl)
inc hl
ld d, (hl)
inc hl
call pushRS
ld (ix), l
ld (ix+1), h
push de
jp exit
NUMBER:
@ -186,6 +159,8 @@ abort:
; Reinitialize PS (RS is reinitialized in forthInterpret
ld sp, (INITIAL_SP)
jp forthRdLine
ABORTREF:
.dw ABORT
.db "BYE"
.fill 5
@ -267,71 +242,35 @@ DEFINE:
; All we need to do is to know how many bytes to copy. To do so, we
; skip compwords until EXIT is reached.
ex de, hl ; DE is our dest
ld (HERE), de ; update HERE
ld l, (ix)
ld h, (ix+1)
.loop:
call HLPointsNUMBER
jr nz, .notNUMBER
; is number
ld bc, 4
ldir
call HLPointsEXIT
jr z, .loopend
call compSkip
jr .loop
.notNUMBER:
call HLPointsLIT
jr nz, .notLIT
; is lit
ldi
ldi
call strcpyM
jr .loop
.notLIT:
; it's a word
call HLPointsIMMED
jr nz, .notIMMED
; Immediate word, we'll have to call it.
; Before we make our call, let's save our current HL/DE position
ld (HERE), de
ld e, (hl)
inc hl
ld d, (hl)
inc hl ; point to next word
push de \ pop iy ; prepare for executeCodeLink
ld (ix), l
ld (ix+1), h
; Push return address
ld hl, .retList
call pushRS
; Ready!
jp executeCodeLink
.notIMMED:
; a good old regular word. We have 2 bytes to copy. But before we do,
; let's check whether it's an EXIT. LDI doesn't affect Z, so we can
; make our jump later.
call HLPointsEXITQUIT
ldi
ldi
jr nz, .loop
; HL has our new RS' TOS
ld (ix), l
ld (ix+1), h
ld (HERE), de ; update HERE
jp exit
; This label is pushed to RS when an IMMED word is called. When that word calls
; exit, this is where it returns. When we return, RS will need to be popped so
; that we stay on the proper RS level.
.retList:
.dw .retWord
.retWord:
.dw .retEntry
.retEntry:
call popRS ; unwind stack
; recall old HL / DE values
.loopend:
; skip EXIT
inc hl \ inc hl
; We have out end offset. Let's get our offset
ld e, (ix)
ld d, (ix+1)
or a ; clear carry
sbc hl, de
; HL is our copy count.
ld b, h
ld c, l
ld l, (ix)
ld h, (ix+1)
ld de, (HERE)
; continue!
jr .loop
ld de, (HERE) ; recall dest
; copy!
ldir
ld (ix), l
ld (ix+1), h
ld (HERE), de
jp exit
.db "DOES>"
.fill 3
@ -374,18 +313,12 @@ IMMEDIATE:
.dw IMMEDIATE
LITERAL:
.dw nativeWord
ld hl, (HERE)
ld hl, (CMPDST)
ld de, NUMBER
ld (hl), e
inc hl
ld (hl), d
inc hl
call DEinHL
pop de ; number from stack
ld (hl), e
inc hl
ld (hl), d
inc hl
ld (HERE), hl
call DEinHL
ld (CMPDST), hl
jp exit
; ( -- c )
@ -400,27 +333,9 @@ KEY:
push hl
jp exit
.db "INTERPR"
.db 0
.dw KEY
INTERPRET:
.dw nativeWord
interpret:
ld iy, COMPBUF
.loop:
call readword
jr nz, .end
call compile
jr .loop
.end:
ld hl, QUIT
call wrCompHL
ld iy, COMPBUF
jp compiledWord
.db "CREATE"
.fill 2
.dw INTERPRET
.dw KEY
CREATE:
.dw nativeWord
call entryhead
@ -474,10 +389,21 @@ STORE:
ld (iy+1), h
jp exit
; ( n a -- )
.db "C!"
.fill 6
.dw STORE
CSTORE:
.dw nativeWord
pop hl
pop de
ld (hl), e
jp exit
; ( a -- n )
.db "@"
.fill 7
.dw STORE
.dw CSTORE
FETCH:
.dw nativeWord
pop hl
@ -485,10 +411,22 @@ FETCH:
push hl
jp exit
; ( a -- c )
.db "C@"
.fill 6
.dw FETCH
CFETCH:
.dw nativeWord
pop hl
ld l, (hl)
ld h, 0
push hl
jp exit
; ( -- a )
.db "LIT@"
.fill 4
.dw FETCH
.dw CFETCH
LITFETCH:
.dw nativeWord
call readLITTOS
@ -506,10 +444,26 @@ SWAP:
push hl
jp exit
; ( a b c d -- c d a b )
.db "2SWAP"
.fill 3
.dw SWAP
SWAP2:
.dw nativeWord
pop de ; D
pop hl ; C
pop bc ; B
ex (sp), hl ; A in HL
push de ; D
push hl ; A
push bc ; B
jp exit
; ( a -- a a )
.db "DUP"
.fill 5
.dw SWAP
.dw SWAP2
DUP:
.dw nativeWord
pop hl
@ -517,10 +471,24 @@ DUP:
push hl
jp exit
; ( a b -- a b a b )
.db "2DUP"
.fill 4
.dw DUP
DUP2:
.dw nativeWord
pop hl ; B
pop de ; A
push de
push hl
push de
push hl
jp exit
; ( a b -- a b a )
.db "OVER"
.fill 4
.dw DUP
.dw DUP2
OVER:
.dw nativeWord
pop hl ; B
@ -530,10 +498,28 @@ OVER:
push de
jp exit
; ( a b c d -- a b c d a b )
.db "2OVER"
.fill 3
.dw OVER
OVER2:
.dw nativeWord
pop hl ; D
pop de ; C
pop bc ; B
pop iy ; A
push iy ; A
push bc ; B
push de ; C
push hl ; D
push iy ; A
push bc ; B
jp exit
; ( a b -- c ) A + B
.db "+"
.fill 7
.dw OVER
.dw OVER2
PLUS:
.dw nativeWord
pop hl
@ -607,22 +593,63 @@ CMP:
jp exit
.db "IF"
.fill 6
.fill 5
.db 1 ; IMMEDIATE
.dw CMP
IF:
.dw ifWord
.dw nativeWord
; Spit a conditional branching atom, followed by an empty 1b cell. Then,
; push the address of that cell on the PS. ELSE or THEN will pick
; them up and set the offset.
ld hl, (CMPDST)
ld de, CBRANCH
call DEinHL
push hl ; address of cell to fill
inc hl ; empty 1b cell
ld (CMPDST), hl
jp exit
.db "ELSE"
.fill 4
.fill 3
.db 1 ; IMMEDIATE
.dw IF
ELSE:
.dw elseWord
.dw nativeWord
; First, let's set IF's branching cell.
pop de ; cell's address
ld hl, (CMPDST)
; also skip ELSE word.
inc hl \ inc hl \ inc hl
or a ; clear carry
sbc hl, de ; HL now has relative offset
ld a, l
ld (de), a
; Set IF's branching cell to current atom address and spit our own
; uncondition branching cell, which will then be picked up by THEN.
; First, let's spit our 4 bytes
ld hl, (CMPDST)
ld de, BRANCH
call DEinHL
push hl ; address of cell to fill
inc hl ; empty 1b cell
ld (CMPDST), hl
jp exit
.db "THEN"
.fill 4
.fill 3
.db 1 ; IMMEDIATE
.dw ELSE
THEN:
.dw thenWord
.dw nativeWord
; See comments in IF and ELSE
pop de ; cell's address
ld hl, (CMPDST)
; There is nothing to skip because THEN leaves nothing.
or a ; clear carry
sbc hl, de ; HL now has relative offset
ld a, l
ld (de), a
jp exit
.db "RECURSE"
.db 0
@ -636,124 +663,5 @@ RECURSE:
push hl \ pop iy
jp compiledWord
; End of native words
; ( a -- )
; @ .
.db "?"
.fill 7
.dw RECURSE
FETCHDOT:
.dw compiledWord
.dw FETCH
.dw DOT
.dw EXIT
; ( n a -- )
; SWAP OVER @ + SWAP !
.db "+!"
.fill 6
.dw FETCHDOT
STOREINC:
.dw compiledWord
.dw SWAP
.dw OVER
.dw FETCH
.dw PLUS
.dw SWAP
.dw STORE
.dw EXIT
; ( n -- )
; HERE +!
.db "ALLOT"
.fill 3
.dw STOREINC
ALLOT:
.dw compiledWord
.dw HERE_
.dw STOREINC
.dw EXIT
; CREATE 2 ALLOT
.db "VARIABL"
.db 0
.dw ALLOT
VARIABLE:
.dw compiledWord
.dw CREATE
.dw NUMBER
.dw 2
.dw ALLOT
.dw EXIT
; ( n -- )
; CREATE HERE @ ! DOES> @
.db "CONSTAN"
.db 0
.dw VARIABLE
CONSTANT:
.dw compiledWord
.dw CREATE
.dw HERE_
.dw FETCH
.dw STORE
.dw DOES
.dw FETCH
.dw EXIT
; ( f -- f )
; IF 0 ELSE 1 THEN
.db "NOT"
.fill 5
.dw CONSTANT
NOT:
.dw compiledWord
.dw IF
.dw NUMBER
.dw 0
.dw ELSE
.dw NUMBER
.dw 1
.dw THEN
.dw EXIT
; ( n1 n2 -- f )
; CMP NOT
.db "="
.fill 7
.dw NOT
EQ:
.dw compiledWord
.dw CMP
.dw NOT
.dw EXIT
; ( n1 n2 -- f )
; CMP -1 =
.db "<"
.fill 7
.dw EQ
LT:
.dw compiledWord
.dw CMP
.dw NUMBER
.dw -1
.dw EQ
.dw EXIT
; ( n1 n2 -- f )
; CMP 1 =
.db ">"
.fill 7
.dw LT
GT:
LATEST:
.dw compiledWord
.dw CMP
.dw NUMBER
.dw 1
.dw EQ
.dw EXIT
;
.dw RECURSE

View File

@ -51,12 +51,17 @@ THEN -- Does nothing. Serves as a branching merker for IF
DUP a -- a a
OVER a b -- a b a
SWAP a b -- b a
2DUP a b -- a b a b
2OVER a b c d -- a b c d a b
2SWAP a b c d -- c d a b
*** Memory ***
@ a -- n Set n to value at address a
! n a -- Store n in address a
? a -- Print value of addr a
+! n a -- Increase value of addr a by n
C@ a -- c Set c to byte at address a
C! c a -- Store byte c in address a
CURRENT -- n Set n to wordref of last added entry.
HERE -- a Push HERE's address

View File

@ -12,11 +12,39 @@
.equ INITIAL_SP FORTH_RAMSTART
.equ CURRENT @+2
.equ HERE @+2
; Pointer to where we currently are in the interpretation of the current line.
.equ INPUTPOS @+2
; Pointer to where compiling words should output. During interpret, it's a
; moving target in (COMPBUF). During DEFINE, it's (HERE).
.equ CMPDST @+2
; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
.equ COMPBUF @+2
.equ FORTH_RAMEND @+0x40
; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0,
; (HERE) will begin at a strategic place.
.equ HERE_INITIAL FORTH_RAMEND
; EXECUTION MODEL
; After having read a line through stdioReadLine, we want to interpret it. As
; a general rule, we go like this:
;
; 1. read single word from line
; 2. compile word to atom
; 3. execute atom
; 4. goto 1
;
; During step 3, it's possible that atom read from input, so INPUTPOS might
; have moved between 3 and 4.
;
; Because the Parameter Stack uses PS, we can't just go around calling routines:
; This messes with the PS. This is why we almost always jump (unless our call
; doesn't involve Forth words in any way).
;
; This presents a challenge for our interpret loop because step 4, "goto 1"
; isn't obvious. To be able to do that, we must push a "return routine" to the
; Return Stack before step 3.
; *** Code ***
forthMain:
; STACK OVERFLOW PROTECTION:
@ -27,19 +55,86 @@ forthMain:
; we check for stack underflow.
push af \ push af \ push af
ld (INITIAL_SP), sp
; LATEST is a *indirect* label to the latest entry of the dict. See
; default at the bottom of dict.asm. This indirection allows us to
; override latest to a value set in a binary dict compiled separately,
; for example by the stage0 bin.
ld hl, LATEST
call intoHL
ld (CURRENT), hl
ld hl, FORTH_RAMEND
ld hl, HERE_INITIAL
ld (HERE), hl
forthRdLine:
ld hl, msgOk
call printstr
call printcrlf
call stdioReadLine
ld (INPUTPOS), hl
forthInterpret:
ld ix, RS_ADDR-2 ; -2 because we inc-before-push
ld iy, INTERPRET
ld (INPUTPOS), hl
ld hl, COMPBUF
ld (CMPDST), hl
forthInterpret:
call readword
jr nz, .execute
call find
jr nz, .maybeNum
ex de, hl
call HLisIMMED
jr z, .immed
ex de, hl
call .writeDE
jr forthInterpret
.maybeNum:
push hl ; --> lvl 1. save string addr
call parseLiteral
pop hl ; <-- lvl 1
jr nz, .undef
; a valid number in DE!
ex de, hl
ld de, NUMBER
call .writeDE
ex de, hl ; number in DE
call .writeDE
jr forthInterpret
.undef:
; When encountering an undefined word during compilation, we spit a
; reference to litWord, followed by the null-terminated word.
; This way, if a preceding word expect a string literal, it will read it
; by calling readLIT, and if it doesn't, the routine will be
; called, triggering an abort.
ld de, LIT
call .writeDE
ld de, (CMPDST)
call strcpyM
ld (CMPDST), de
jr forthInterpret
.immed:
push hl ; --> lvl 1
ld hl, .retRef
call pushRS
pop iy ; <-- lvl 1
jp executeCodeLink
.execute:
ld de, QUIT
call .writeDE
ld iy, COMPBUF
jp compiledWord
.writeDE:
push hl
ld hl, (CMPDST)
ld (hl), e
inc hl
ld (hl), d
inc hl
ld (CMPDST), hl
pop hl
ret
.retRef:
.dw $+2
.dw $+2
call popRS
jr forthInterpret
msgOk:
.db " ok", 0

View File

@ -25,6 +25,17 @@ popRS:
dec ix
ret
; Skip the next two bytes in RS' TOS
skipRS:
push hl
ld l, (ix)
ld h, (ix+1)
inc hl \ inc hl
ld (ix), l
ld (ix+1), h
pop hl
ret
; Verifies that SP is within bounds. If it's not, call ABORT
chkPS:
ld hl, (INITIAL_SP)

View File

@ -69,14 +69,28 @@ HLPointsLIT:
pop de
ret
HLPointsEXITQUIT:
HLPointsBRANCH:
push de
ld de, BRANCH
call HLPointsDE
jr z, .end
ld de, CBRANCH
call HLPointsDE
.end:
pop de
ret
HLPointsEXIT:
push de
ld de, EXIT
call HLPointsDE
jr z, .end
pop de
ret
HLPointsQUIT:
push de
ld de, QUIT
call HLPointsDE
.end:
pop de
ret
@ -86,6 +100,8 @@ HLPointsEXITQUIT:
compSkip:
call HLPointsNUMBER
jr z, .isNum
call HLPointsBRANCH
jr z, .isBranch
call HLPointsLIT
jr nz, .isWord
; We have a literal
@ -95,7 +111,11 @@ compSkip:
ret
.isNum:
; skip by 4
inc hl \ inc hl
inc hl
; continue to isBranch
.isBranch:
; skip by 3
inc hl
; continue to isWord
.isWord:
; skip by 2
@ -160,7 +180,11 @@ readLIT:
; it's a word.
call HLPointsNUMBER
jr z, .notWord
call HLPointsEXITQUIT
call HLPointsBRANCH
jr z, .notWord
call HLPointsEXIT
jr z, .notWord
call HLPointsQUIT
jr z, .notWord
; Not a number, then it's a word. Copy word to pad and point to it.
push hl ; --> lvl 1. we need it to set DE later
@ -257,42 +281,6 @@ wrCompHL:
inc iy
ret
; Compile word string at (HL) and write down its compiled version in IY,
; advancing IY to the byte next to the last written byte.
compile:
call find
jr nz, .maybeNum
ex de, hl
jr wrCompHL
.maybeNum:
push hl ; --> lvl 1. save string addr
call parseLiteral
jr nz, .undef
pop hl ; <-- lvl 1
; a valid number!
ld hl, NUMBER
call wrCompHL
ex de, hl ; number in HL
jr wrCompHL
.undef:
; When encountering an undefined word during compilation, we spit a
; reference to litWord, followed by the null-terminated word.
; This way, if a preceding word expect a string literal, it will read it
; by calling readLIT, and if it doesn't, the routine will be
; called, triggering an abort.
ld hl, LIT
call wrCompHL
pop hl ; <-- lvl 1. recall string addr
.writeLit:
ld a, (hl)
ld (iy), a
inc hl
inc iy
or a
jr nz, .writeLit
ret
; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
entryhead:
@ -315,10 +303,8 @@ entryhead:
xor a ; set Z
ret
; Sets Z if wordref at (HL) is of the IMMEDIATE type
HLPointsIMMED:
push hl
call intoHL
; Sets Z if wordref at HL is of the IMMEDIATE type
HLisIMMED:
dec hl
dec hl
dec hl
@ -329,6 +315,13 @@ HLPointsIMMED:
inc hl
inc hl
inc hl
ret
; Sets Z if wordref at (HL) is of the IMMEDIATE type
HLPointsIMMED:
push hl
call intoHL
call HLisIMMED
pop hl
ret
@ -343,3 +336,10 @@ flagsToBC:
dec bc
ret
; Write DE in (HL), advancing HL by 2.
DEinHL:
ld (hl), e
inc hl
ld (hl), d
inc hl
ret

1
emul/.gitignore vendored
View File

@ -1,4 +1,5 @@
/shell/shell
/forth/stage1
/forth/forth
/zasm/zasm
/zasm/avra

View File

@ -24,13 +24,25 @@ shell/shell-bin.h: shell/shell.bin
shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h
$(CC) shell/shell.c $(SHELLOBJS) -o $@
forth/forth.bin: forth/glue.asm $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
forth/forth0.bin: forth/glue0.asm $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null
forth/forth-bin.h: forth/forth.bin
./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
forth/forth0-bin.h: forth/forth0.bin
./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null
forth/forth: forth/forth.c $(OBJS) forth/forth-bin.h
forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h
$(CC) forth/stage1.c $(OBJS) -o $@
forth/core.bin: $(APPS)/forth/core.fth forth/stage1
./forth/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null
forth/forth1.bin: forth/glue1.asm forth/core.bin $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) forth/core.bin < forth/glue1.asm | tee $@ > /dev/null
forth/forth1-bin.h: forth/forth1.bin
./bin2c.sh KERNEL < forth/forth1.bin | tee $@ > /dev/null
forth/forth: forth/forth.c $(OBJS) forth/forth1-bin.h
$(CC) forth/forth.c $(OBJS) -o $@
zasm/kernel-bin.h: zasm/kernel.bin

View File

@ -3,17 +3,18 @@
#include <unistd.h>
#include <termios.h>
#include "../emul.h"
#include "forth-bin.h"
#include "forth1-bin.h"
// in sync with glue.asm
#define RAMSTART 0x2000
#define RAMSTART 0x900
#define STDIO_PORT 0x00
static int running;
static FILE *fp;
static uint8_t iord_stdio()
{
int c = getchar();
int c = getc(fp);
if (c == EOF) {
running = 0;
}
@ -31,8 +32,17 @@ static void iowr_stdio(uint8_t val)
int main(int argc, char *argv[])
{
bool tty = isatty(fileno(stdin));
bool tty = false;
struct termios termInfo;
if (argc == 2) {
fp = fopen(argv[1], "r");
if (fp == NULL) {
fprintf(stderr, "Can't open %s\n", argv[1]);
return 1;
}
} else if (argc == 1) {
fp = stdin;
tty = isatty(fileno(stdin));
if (tty) {
// Turn echo off: the shell takes care of its own echoing.
if (tcgetattr(0, &termInfo) == -1) {
@ -43,7 +53,10 @@ int main(int argc, char *argv[])
termInfo.c_lflag &= ~ICANON;
tcsetattr(0, TCSAFLUSH, &termInfo);
}
} else {
fprintf(stderr, "Usage: ./forth [filename]\n");
return 1;
}
Machine *m = emul_init();
m->ramstart = RAMSTART;
m->iord[STDIO_PORT] = iord_stdio;
@ -58,11 +71,12 @@ int main(int argc, char *argv[])
while (running && emul_step());
if (tty) {
printf("Done!\n");
printf("\nDone!\n");
termInfo.c_lflag |= ECHO;
termInfo.c_lflag |= ICANON;
tcsetattr(0, TCSAFLUSH, &termInfo);
emul_printdebug();
}
fclose(fp);
return 0;
}

56
emul/forth/glue0.asm Normal file
View File

@ -0,0 +1,56 @@
; RAM disposition
;
; Because this glue code also serves stage0 which needs HERE to start right
; after the code, we have a peculiar RAM setup here: it lives at the very end
; of the address space, just under RS_ADDR at 0xf000
; Warning: The offsets of native dict entries must be exactly the same between
; glue0.asm and glue1.asm
.equ RAMSTART 0xe800
.equ HERE 0xe700 ; override, in sync with stage1.c
.equ CURRENT 0xe702 ; override, in sync with stage1.c
.equ HERE_INITIAL CODE_END ; override
.inc "ascii.h"
.equ STDIO_PORT 0x00
jp init
.inc "core.asm"
.inc "str.asm"
.equ STDIO_RAMSTART RAMSTART
.equ STDIO_GETC emulGetC
.equ STDIO_PUTC emulPutC
.inc "stdio.asm"
.inc "lib/util.asm"
.inc "lib/parse.asm"
.inc "lib/ari.asm"
.inc "lib/fmt.asm"
.equ FORTH_RAMSTART STDIO_RAMEND
.inc "forth/main.asm"
.inc "forth/util.asm"
.inc "forth/stack.asm"
.inc "forth/dict.asm"
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
.dw 0 ; placeholder used in glue1.
CODE_END:
.out $ ; should be the same as in glue1

View File

@ -1,5 +1,7 @@
; Warning: The offsets of native dict entries must be exactly the same between
; glue0.asm and glue1.asm
.equ LATEST CODE_END ; override
.inc "ascii.h"
.equ RAMSTART 0x2000
.equ STDIO_PORT 0x00
jp init
@ -22,6 +24,7 @@
.inc "forth/stack.asm"
.inc "forth/dict.asm"
init:
di
; setup stack
@ -38,3 +41,10 @@ emulGetC:
emulPutC:
out (STDIO_PORT), a
ret
.out $ ; should be the same as in glue0, minus 2
; stage0 spits, at the beginning of the binary, the address of the latest word
; Therefore, we can set the LATEST label to here and we should be good.
CODE_END:
.bin "core.bin"
RAMSTART:

87
emul/forth/stage1.c Normal file
View File

@ -0,0 +1,87 @@
#include <stdint.h>
#include <stdio.h>
#include <unistd.h>
#include "../emul.h"
#include "forth0-bin.h"
/* Stage 1
The role of the stage 1 executable is to start from a bare Forth executable
(stage 0) that will compile core non-native definitions into binary form and
append this to existing bootstrap binary to form our final Forth bin.
We could, if we wanted, run only with the bootstrap binary and compile core
defs at runtime, but that would mean that those defs live in RAM. In may system,
RAM is much more constrained than ROM, so it's worth it to give ourselves the
trouble of compiling defs to binary.
This stage 0 executable has to be layed out in a particular manner: HERE must
directly follow executable's last byte so that we don't waste spce and also
that wordref offsets correspond.
*/
// in sync with glue.asm
#define RAMSTART 0x900
#define STDIO_PORT 0x00
// In sync with glue code. This way, we can know where HERE was when we stopped
// running
#define HERE 0xe700
// We also need to know what CURRENT is so we can write our first two bytes
#define CURRENT 0xe702
static int running;
static FILE *fp;
static uint8_t iord_stdio()
{
int c = getc(fp);
if (c == EOF) {
running = 0;
}
return (uint8_t)c;
}
static void iowr_stdio(uint8_t val)
{
// we don't output stdout in stage0
}
int main(int argc, char *argv[])
{
bool tty = false;
if (argc == 2) {
fp = fopen(argv[1], "r");
if (fp == NULL) {
fprintf(stderr, "Can't open %s\n", argv[1]);
return 1;
}
} else {
fprintf(stderr, "Usage: ./stage0 filename\n");
return 1;
}
Machine *m = emul_init();
m->ramstart = RAMSTART;
m->iord[STDIO_PORT] = iord_stdio;
m->iowr[STDIO_PORT] = iowr_stdio;
// initialize memory
for (int i=0; i<sizeof(KERNEL); i++) {
m->mem[i] = KERNEL[i];
}
// Run!
running = 1;
while (running && emul_step());
fclose(fp);
// We're done, now let's spit dict data
// let's start with LATEST spitting.
putchar(m->mem[CURRENT]);
putchar(m->mem[CURRENT+1]);
uint16_t here = m->mem[HERE] + (m->mem[HERE+1] << 8);
for (int i=sizeof(KERNEL); i<here; i++) {
putchar(m->mem[i]);
}
return 0;
}