mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 18:20:55 +11:00
Compare commits
9 Commits
2ddca57f3f
...
a8e573c84a
Author | SHA1 | Date | |
---|---|---|---|
|
a8e573c84a | ||
|
f89e7bd503 | ||
|
80f63cd185 | ||
|
d8542f7cf7 | ||
|
ea5f33558a | ||
|
abdf2c8adc | ||
|
3996f0c825 | ||
|
02b56c547a | ||
|
6757c097ea |
9
apps/forth/core.fth
Normal file
9
apps/forth/core.fth
Normal 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 = ;
|
@ -51,69 +51,40 @@ doesWord:
|
|||||||
push hl \ pop iy
|
push hl \ pop iy
|
||||||
jr compiledWord
|
jr compiledWord
|
||||||
|
|
||||||
; The IF word checks the stack for zero. If it's non-zero, it does nothing and
|
; This word is followed by 1b *relative* offset (to the cell's addr) to where to
|
||||||
; allow compiledWord to continue.
|
; branch to. For example, The branching cell of "IF THEN" would contain 3. Add
|
||||||
; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
|
; this value to RS.
|
||||||
; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
|
branchWord:
|
||||||
; it's a ELSE or THEN, the same thing happens: we resume execution after the
|
push de
|
||||||
; ELSE/THEN. If it's a EXIT, we simply execute it.
|
ld l, (ix)
|
||||||
ifWord:
|
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
|
pop hl
|
||||||
ld a, h
|
ld a, h
|
||||||
or l
|
or l
|
||||||
jp nz, exit ; non-zero, continue
|
jr z, branchWord
|
||||||
; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
|
; skip next byte in RS
|
||||||
|
ld l, (ix)
|
||||||
; If a ELSE word is executed, it means that the preceding IF had a non-zero
|
ld h, (ix+1)
|
||||||
; condition and continued execution. This means that upon encountering an ELSE,
|
inc hl
|
||||||
; we must search for a THEN or an EXIT.
|
ld (ix), l
|
||||||
; To simplify implementation and share code with ifWord, we also match ELSE,
|
ld (ix+1), h
|
||||||
; 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:
|
|
||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
|
CBRANCH:
|
||||||
|
.dw cbranchWord
|
||||||
|
|
||||||
; This is not a word, but a number literal. This works a bit differently than
|
; 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
|
; 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
|
; 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
|
; it to the Parameter stack and then push an increase Interpreter Pointer back
|
||||||
; to RS.
|
; to RS.
|
||||||
numberWord:
|
numberWord:
|
||||||
call popRS
|
ld l, (ix)
|
||||||
|
ld h, (ix+1)
|
||||||
ld e, (hl)
|
ld e, (hl)
|
||||||
inc hl
|
inc hl
|
||||||
ld d, (hl)
|
ld d, (hl)
|
||||||
inc hl
|
inc hl
|
||||||
call pushRS
|
ld (ix), l
|
||||||
|
ld (ix+1), h
|
||||||
push de
|
push de
|
||||||
jp exit
|
jp exit
|
||||||
NUMBER:
|
NUMBER:
|
||||||
@ -186,6 +159,8 @@ abort:
|
|||||||
; Reinitialize PS (RS is reinitialized in forthInterpret
|
; Reinitialize PS (RS is reinitialized in forthInterpret
|
||||||
ld sp, (INITIAL_SP)
|
ld sp, (INITIAL_SP)
|
||||||
jp forthRdLine
|
jp forthRdLine
|
||||||
|
ABORTREF:
|
||||||
|
.dw ABORT
|
||||||
|
|
||||||
.db "BYE"
|
.db "BYE"
|
||||||
.fill 5
|
.fill 5
|
||||||
@ -267,71 +242,35 @@ DEFINE:
|
|||||||
; All we need to do is to know how many bytes to copy. To do so, we
|
; All we need to do is to know how many bytes to copy. To do so, we
|
||||||
; skip compwords until EXIT is reached.
|
; skip compwords until EXIT is reached.
|
||||||
ex de, hl ; DE is our dest
|
ex de, hl ; DE is our dest
|
||||||
|
ld (HERE), de ; update HERE
|
||||||
ld l, (ix)
|
ld l, (ix)
|
||||||
ld h, (ix+1)
|
ld h, (ix+1)
|
||||||
.loop:
|
.loop:
|
||||||
call HLPointsNUMBER
|
call HLPointsEXIT
|
||||||
jr nz, .notNUMBER
|
jr z, .loopend
|
||||||
; is number
|
call compSkip
|
||||||
ld bc, 4
|
|
||||||
ldir
|
|
||||||
jr .loop
|
jr .loop
|
||||||
.notNUMBER:
|
.loopend:
|
||||||
call HLPointsLIT
|
; skip EXIT
|
||||||
jr nz, .notLIT
|
inc hl \ inc hl
|
||||||
; is lit
|
; We have out end offset. Let's get our offset
|
||||||
ldi
|
ld e, (ix)
|
||||||
ldi
|
ld d, (ix+1)
|
||||||
call strcpyM
|
or a ; clear carry
|
||||||
jr .loop
|
sbc hl, de
|
||||||
.notLIT:
|
; HL is our copy count.
|
||||||
; it's a word
|
ld b, h
|
||||||
call HLPointsIMMED
|
ld c, l
|
||||||
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
|
|
||||||
ld l, (ix)
|
ld l, (ix)
|
||||||
ld h, (ix+1)
|
ld h, (ix+1)
|
||||||
ld de, (HERE)
|
ld de, (HERE) ; recall dest
|
||||||
; continue!
|
; copy!
|
||||||
jr .loop
|
ldir
|
||||||
|
ld (ix), l
|
||||||
|
ld (ix+1), h
|
||||||
|
ld (HERE), de
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
|
||||||
.db "DOES>"
|
.db "DOES>"
|
||||||
.fill 3
|
.fill 3
|
||||||
@ -374,18 +313,12 @@ IMMEDIATE:
|
|||||||
.dw IMMEDIATE
|
.dw IMMEDIATE
|
||||||
LITERAL:
|
LITERAL:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
ld hl, (HERE)
|
ld hl, (CMPDST)
|
||||||
ld de, NUMBER
|
ld de, NUMBER
|
||||||
ld (hl), e
|
call DEinHL
|
||||||
inc hl
|
|
||||||
ld (hl), d
|
|
||||||
inc hl
|
|
||||||
pop de ; number from stack
|
pop de ; number from stack
|
||||||
ld (hl), e
|
call DEinHL
|
||||||
inc hl
|
ld (CMPDST), hl
|
||||||
ld (hl), d
|
|
||||||
inc hl
|
|
||||||
ld (HERE), hl
|
|
||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
; ( -- c )
|
; ( -- c )
|
||||||
@ -400,27 +333,9 @@ KEY:
|
|||||||
push hl
|
push hl
|
||||||
jp exit
|
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"
|
.db "CREATE"
|
||||||
.fill 2
|
.fill 2
|
||||||
.dw INTERPRET
|
.dw KEY
|
||||||
CREATE:
|
CREATE:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
call entryhead
|
call entryhead
|
||||||
@ -474,10 +389,21 @@ STORE:
|
|||||||
ld (iy+1), h
|
ld (iy+1), h
|
||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
|
; ( n a -- )
|
||||||
|
.db "C!"
|
||||||
|
.fill 6
|
||||||
|
.dw STORE
|
||||||
|
CSTORE:
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
pop de
|
||||||
|
ld (hl), e
|
||||||
|
jp exit
|
||||||
|
|
||||||
; ( a -- n )
|
; ( a -- n )
|
||||||
.db "@"
|
.db "@"
|
||||||
.fill 7
|
.fill 7
|
||||||
.dw STORE
|
.dw CSTORE
|
||||||
FETCH:
|
FETCH:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop hl
|
pop hl
|
||||||
@ -485,10 +411,22 @@ FETCH:
|
|||||||
push hl
|
push hl
|
||||||
jp exit
|
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 )
|
; ( -- a )
|
||||||
.db "LIT@"
|
.db "LIT@"
|
||||||
.fill 4
|
.fill 4
|
||||||
.dw FETCH
|
.dw CFETCH
|
||||||
LITFETCH:
|
LITFETCH:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
call readLITTOS
|
call readLITTOS
|
||||||
@ -506,10 +444,26 @@ SWAP:
|
|||||||
push hl
|
push hl
|
||||||
jp exit
|
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 )
|
; ( a -- a a )
|
||||||
.db "DUP"
|
.db "DUP"
|
||||||
.fill 5
|
.fill 5
|
||||||
.dw SWAP
|
.dw SWAP2
|
||||||
DUP:
|
DUP:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop hl
|
pop hl
|
||||||
@ -517,10 +471,24 @@ DUP:
|
|||||||
push hl
|
push hl
|
||||||
jp exit
|
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 )
|
; ( a b -- a b a )
|
||||||
.db "OVER"
|
.db "OVER"
|
||||||
.fill 4
|
.fill 4
|
||||||
.dw DUP
|
.dw DUP2
|
||||||
OVER:
|
OVER:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop hl ; B
|
pop hl ; B
|
||||||
@ -530,10 +498,28 @@ OVER:
|
|||||||
push de
|
push de
|
||||||
jp exit
|
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
|
; ( a b -- c ) A + B
|
||||||
.db "+"
|
.db "+"
|
||||||
.fill 7
|
.fill 7
|
||||||
.dw OVER
|
.dw OVER2
|
||||||
PLUS:
|
PLUS:
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop hl
|
pop hl
|
||||||
@ -607,22 +593,63 @@ CMP:
|
|||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
.db "IF"
|
.db "IF"
|
||||||
.fill 6
|
.fill 5
|
||||||
|
.db 1 ; IMMEDIATE
|
||||||
.dw CMP
|
.dw CMP
|
||||||
IF:
|
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"
|
.db "ELSE"
|
||||||
.fill 4
|
.fill 3
|
||||||
|
.db 1 ; IMMEDIATE
|
||||||
.dw IF
|
.dw IF
|
||||||
ELSE:
|
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"
|
.db "THEN"
|
||||||
.fill 4
|
.fill 3
|
||||||
|
.db 1 ; IMMEDIATE
|
||||||
.dw ELSE
|
.dw ELSE
|
||||||
THEN:
|
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 "RECURSE"
|
||||||
.db 0
|
.db 0
|
||||||
@ -636,124 +663,5 @@ RECURSE:
|
|||||||
push hl \ pop iy
|
push hl \ pop iy
|
||||||
jp compiledWord
|
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:
|
LATEST:
|
||||||
.dw compiledWord
|
.dw RECURSE
|
||||||
.dw CMP
|
|
||||||
.dw NUMBER
|
|
||||||
.dw 1
|
|
||||||
.dw EQ
|
|
||||||
.dw EXIT
|
|
||||||
|
|
||||||
;
|
|
||||||
|
@ -51,12 +51,17 @@ THEN -- Does nothing. Serves as a branching merker for IF
|
|||||||
DUP a -- a a
|
DUP a -- a a
|
||||||
OVER a b -- a b a
|
OVER a b -- a b a
|
||||||
SWAP a b -- 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 ***
|
*** Memory ***
|
||||||
@ a -- n Set n to value at address a
|
@ a -- n Set n to value at address a
|
||||||
! n a -- Store n in address a
|
! n a -- Store n in address a
|
||||||
? a -- Print value of addr a
|
? a -- Print value of addr a
|
||||||
+! n a -- Increase value of addr a by n
|
+! 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.
|
CURRENT -- n Set n to wordref of last added entry.
|
||||||
HERE -- a Push HERE's address
|
HERE -- a Push HERE's address
|
||||||
|
|
||||||
|
@ -12,11 +12,39 @@
|
|||||||
.equ INITIAL_SP FORTH_RAMSTART
|
.equ INITIAL_SP FORTH_RAMSTART
|
||||||
.equ CURRENT @+2
|
.equ CURRENT @+2
|
||||||
.equ HERE @+2
|
.equ HERE @+2
|
||||||
|
; Pointer to where we currently are in the interpretation of the current line.
|
||||||
.equ INPUTPOS @+2
|
.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.
|
; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
|
||||||
.equ COMPBUF @+2
|
.equ COMPBUF @+2
|
||||||
.equ FORTH_RAMEND @+0x40
|
.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 ***
|
; *** Code ***
|
||||||
forthMain:
|
forthMain:
|
||||||
; STACK OVERFLOW PROTECTION:
|
; STACK OVERFLOW PROTECTION:
|
||||||
@ -27,19 +55,86 @@ forthMain:
|
|||||||
; we check for stack underflow.
|
; we check for stack underflow.
|
||||||
push af \ push af \ push af
|
push af \ push af \ push af
|
||||||
ld (INITIAL_SP), sp
|
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
|
ld hl, LATEST
|
||||||
|
call intoHL
|
||||||
ld (CURRENT), hl
|
ld (CURRENT), hl
|
||||||
ld hl, FORTH_RAMEND
|
ld hl, HERE_INITIAL
|
||||||
ld (HERE), hl
|
ld (HERE), hl
|
||||||
forthRdLine:
|
forthRdLine:
|
||||||
ld hl, msgOk
|
ld hl, msgOk
|
||||||
call printstr
|
call printstr
|
||||||
call printcrlf
|
call printcrlf
|
||||||
call stdioReadLine
|
call stdioReadLine
|
||||||
ld (INPUTPOS), hl
|
|
||||||
forthInterpret:
|
|
||||||
ld ix, RS_ADDR-2 ; -2 because we inc-before-push
|
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
|
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:
|
msgOk:
|
||||||
.db " ok", 0
|
.db " ok", 0
|
||||||
|
@ -25,6 +25,17 @@ popRS:
|
|||||||
dec ix
|
dec ix
|
||||||
ret
|
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
|
; Verifies that SP is within bounds. If it's not, call ABORT
|
||||||
chkPS:
|
chkPS:
|
||||||
ld hl, (INITIAL_SP)
|
ld hl, (INITIAL_SP)
|
||||||
|
@ -69,14 +69,28 @@ HLPointsLIT:
|
|||||||
pop de
|
pop de
|
||||||
ret
|
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
|
push de
|
||||||
ld de, EXIT
|
ld de, EXIT
|
||||||
call HLPointsDE
|
call HLPointsDE
|
||||||
jr z, .end
|
pop de
|
||||||
|
ret
|
||||||
|
|
||||||
|
HLPointsQUIT:
|
||||||
|
push de
|
||||||
ld de, QUIT
|
ld de, QUIT
|
||||||
call HLPointsDE
|
call HLPointsDE
|
||||||
.end:
|
|
||||||
pop de
|
pop de
|
||||||
ret
|
ret
|
||||||
|
|
||||||
@ -86,6 +100,8 @@ HLPointsEXITQUIT:
|
|||||||
compSkip:
|
compSkip:
|
||||||
call HLPointsNUMBER
|
call HLPointsNUMBER
|
||||||
jr z, .isNum
|
jr z, .isNum
|
||||||
|
call HLPointsBRANCH
|
||||||
|
jr z, .isBranch
|
||||||
call HLPointsLIT
|
call HLPointsLIT
|
||||||
jr nz, .isWord
|
jr nz, .isWord
|
||||||
; We have a literal
|
; We have a literal
|
||||||
@ -95,7 +111,11 @@ compSkip:
|
|||||||
ret
|
ret
|
||||||
.isNum:
|
.isNum:
|
||||||
; skip by 4
|
; skip by 4
|
||||||
inc hl \ inc hl
|
inc hl
|
||||||
|
; continue to isBranch
|
||||||
|
.isBranch:
|
||||||
|
; skip by 3
|
||||||
|
inc hl
|
||||||
; continue to isWord
|
; continue to isWord
|
||||||
.isWord:
|
.isWord:
|
||||||
; skip by 2
|
; skip by 2
|
||||||
@ -160,7 +180,11 @@ readLIT:
|
|||||||
; it's a word.
|
; it's a word.
|
||||||
call HLPointsNUMBER
|
call HLPointsNUMBER
|
||||||
jr z, .notWord
|
jr z, .notWord
|
||||||
call HLPointsEXITQUIT
|
call HLPointsBRANCH
|
||||||
|
jr z, .notWord
|
||||||
|
call HLPointsEXIT
|
||||||
|
jr z, .notWord
|
||||||
|
call HLPointsQUIT
|
||||||
jr z, .notWord
|
jr z, .notWord
|
||||||
; Not a number, then it's a word. Copy word to pad and point to it.
|
; 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
|
push hl ; --> lvl 1. we need it to set DE later
|
||||||
@ -257,42 +281,6 @@ wrCompHL:
|
|||||||
inc iy
|
inc iy
|
||||||
ret
|
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)
|
; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
|
||||||
; HL points to new (HERE)
|
; HL points to new (HERE)
|
||||||
entryhead:
|
entryhead:
|
||||||
@ -315,10 +303,8 @@ entryhead:
|
|||||||
xor a ; set Z
|
xor a ; set Z
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Sets Z if wordref at (HL) is of the IMMEDIATE type
|
; Sets Z if wordref at HL is of the IMMEDIATE type
|
||||||
HLPointsIMMED:
|
HLisIMMED:
|
||||||
push hl
|
|
||||||
call intoHL
|
|
||||||
dec hl
|
dec hl
|
||||||
dec hl
|
dec hl
|
||||||
dec hl
|
dec hl
|
||||||
@ -329,6 +315,13 @@ HLPointsIMMED:
|
|||||||
inc hl
|
inc hl
|
||||||
inc hl
|
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
|
pop hl
|
||||||
ret
|
ret
|
||||||
|
|
||||||
@ -343,3 +336,10 @@ flagsToBC:
|
|||||||
dec bc
|
dec bc
|
||||||
ret
|
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
1
emul/.gitignore
vendored
@ -1,4 +1,5 @@
|
|||||||
/shell/shell
|
/shell/shell
|
||||||
|
/forth/stage1
|
||||||
/forth/forth
|
/forth/forth
|
||||||
/zasm/zasm
|
/zasm/zasm
|
||||||
/zasm/avra
|
/zasm/avra
|
||||||
|
@ -24,13 +24,25 @@ shell/shell-bin.h: shell/shell.bin
|
|||||||
shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h
|
shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h
|
||||||
$(CC) shell/shell.c $(SHELLOBJS) -o $@
|
$(CC) shell/shell.c $(SHELLOBJS) -o $@
|
||||||
|
|
||||||
forth/forth.bin: forth/glue.asm $(ZASMBIN)
|
forth/forth0.bin: forth/glue0.asm $(ZASMBIN)
|
||||||
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
|
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null
|
||||||
|
|
||||||
forth/forth-bin.h: forth/forth.bin
|
forth/forth0-bin.h: forth/forth0.bin
|
||||||
./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
|
./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 $@
|
$(CC) forth/forth.c $(OBJS) -o $@
|
||||||
|
|
||||||
zasm/kernel-bin.h: zasm/kernel.bin
|
zasm/kernel-bin.h: zasm/kernel.bin
|
||||||
|
@ -3,17 +3,18 @@
|
|||||||
#include <unistd.h>
|
#include <unistd.h>
|
||||||
#include <termios.h>
|
#include <termios.h>
|
||||||
#include "../emul.h"
|
#include "../emul.h"
|
||||||
#include "forth-bin.h"
|
#include "forth1-bin.h"
|
||||||
|
|
||||||
// in sync with glue.asm
|
// in sync with glue.asm
|
||||||
#define RAMSTART 0x2000
|
#define RAMSTART 0x900
|
||||||
#define STDIO_PORT 0x00
|
#define STDIO_PORT 0x00
|
||||||
|
|
||||||
static int running;
|
static int running;
|
||||||
|
static FILE *fp;
|
||||||
|
|
||||||
static uint8_t iord_stdio()
|
static uint8_t iord_stdio()
|
||||||
{
|
{
|
||||||
int c = getchar();
|
int c = getc(fp);
|
||||||
if (c == EOF) {
|
if (c == EOF) {
|
||||||
running = 0;
|
running = 0;
|
||||||
}
|
}
|
||||||
@ -31,8 +32,17 @@ static void iowr_stdio(uint8_t val)
|
|||||||
|
|
||||||
int main(int argc, char *argv[])
|
int main(int argc, char *argv[])
|
||||||
{
|
{
|
||||||
bool tty = isatty(fileno(stdin));
|
bool tty = false;
|
||||||
struct termios termInfo;
|
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) {
|
if (tty) {
|
||||||
// Turn echo off: the shell takes care of its own echoing.
|
// Turn echo off: the shell takes care of its own echoing.
|
||||||
if (tcgetattr(0, &termInfo) == -1) {
|
if (tcgetattr(0, &termInfo) == -1) {
|
||||||
@ -43,7 +53,10 @@ int main(int argc, char *argv[])
|
|||||||
termInfo.c_lflag &= ~ICANON;
|
termInfo.c_lflag &= ~ICANON;
|
||||||
tcsetattr(0, TCSAFLUSH, &termInfo);
|
tcsetattr(0, TCSAFLUSH, &termInfo);
|
||||||
}
|
}
|
||||||
|
} else {
|
||||||
|
fprintf(stderr, "Usage: ./forth [filename]\n");
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
Machine *m = emul_init();
|
Machine *m = emul_init();
|
||||||
m->ramstart = RAMSTART;
|
m->ramstart = RAMSTART;
|
||||||
m->iord[STDIO_PORT] = iord_stdio;
|
m->iord[STDIO_PORT] = iord_stdio;
|
||||||
@ -58,11 +71,12 @@ int main(int argc, char *argv[])
|
|||||||
while (running && emul_step());
|
while (running && emul_step());
|
||||||
|
|
||||||
if (tty) {
|
if (tty) {
|
||||||
printf("Done!\n");
|
printf("\nDone!\n");
|
||||||
termInfo.c_lflag |= ECHO;
|
termInfo.c_lflag |= ECHO;
|
||||||
termInfo.c_lflag |= ICANON;
|
termInfo.c_lflag |= ICANON;
|
||||||
tcsetattr(0, TCSAFLUSH, &termInfo);
|
tcsetattr(0, TCSAFLUSH, &termInfo);
|
||||||
emul_printdebug();
|
emul_printdebug();
|
||||||
}
|
}
|
||||||
|
fclose(fp);
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
56
emul/forth/glue0.asm
Normal file
56
emul/forth/glue0.asm
Normal 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
|
@ -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"
|
.inc "ascii.h"
|
||||||
.equ RAMSTART 0x2000
|
|
||||||
.equ STDIO_PORT 0x00
|
.equ STDIO_PORT 0x00
|
||||||
|
|
||||||
jp init
|
jp init
|
||||||
@ -22,6 +24,7 @@
|
|||||||
.inc "forth/stack.asm"
|
.inc "forth/stack.asm"
|
||||||
.inc "forth/dict.asm"
|
.inc "forth/dict.asm"
|
||||||
|
|
||||||
|
|
||||||
init:
|
init:
|
||||||
di
|
di
|
||||||
; setup stack
|
; setup stack
|
||||||
@ -38,3 +41,10 @@ emulGetC:
|
|||||||
emulPutC:
|
emulPutC:
|
||||||
out (STDIO_PORT), a
|
out (STDIO_PORT), a
|
||||||
ret
|
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
87
emul/forth/stage1.c
Normal 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;
|
||||||
|
}
|
||||||
|
|
Loading…
Reference in New Issue
Block a user