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

Compare commits

..

No commits in common. "a8e573c84a5773d2280e57f3f0fce53fd2307eed" and "2ddca57f3fc9c79b4d41d46fdc2076a71ca30fc6" have entirely different histories.

12 changed files with 344 additions and 552 deletions

View File

@ -1,9 +0,0 @@
: ? @ . ;
: +! 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,39 +51,68 @@ doesWord:
push hl \ pop iy push hl \ pop iy
jr compiledWord jr compiledWord
; This word is followed by 1b *relative* offset (to the cell's addr) to where to ; The IF word checks the stack for zero. If it's non-zero, it does nothing and
; branch to. For example, The branching cell of "IF THEN" would contain 3. Add ; allow compiledWord to continue.
; this value to RS. ; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
branchWord: ; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
push de ; it's a ELSE or THEN, the same thing happens: we resume execution after the
ld l, (ix) ; ELSE/THEN. If it's a EXIT, we simply execute it.
ld h, (ix+1) ifWord:
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
jr z, branchWord jp nz, exit ; non-zero, continue
; skip next byte in RS ; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
ld l, (ix)
ld h, (ix+1)
inc hl
ld (ix), l
ld (ix+1), h
jp exit
CBRANCH: ; If a ELSE word is executed, it means that the preceding IF had a non-zero
.dw cbranchWord ; 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:
jp exit
; 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
@ -92,14 +121,12 @@ CBRANCH:
; 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:
ld l, (ix) call popRS
ld h, (ix+1)
ld e, (hl) ld e, (hl)
inc hl inc hl
ld d, (hl) ld d, (hl)
inc hl inc hl
ld (ix), l call pushRS
ld (ix+1), h
push de push de
jp exit jp exit
NUMBER: NUMBER:
@ -159,8 +186,6 @@ 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
@ -242,35 +267,71 @@ 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 HLPointsEXIT call HLPointsNUMBER
jr z, .loopend jr nz, .notNUMBER
call compSkip ; is number
jr .loop ld bc, 4
.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) ; recall dest
; copy!
ldir ldir
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), l
ld (ix+1), h ld (ix+1), h
ld (HERE), de ; 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 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 h, (ix+1)
ld de, (HERE)
; continue!
jr .loop
.db "DOES>" .db "DOES>"
.fill 3 .fill 3
@ -313,12 +374,18 @@ IMMEDIATE:
.dw IMMEDIATE .dw IMMEDIATE
LITERAL: LITERAL:
.dw nativeWord .dw nativeWord
ld hl, (CMPDST) ld hl, (HERE)
ld de, NUMBER ld de, NUMBER
call DEinHL ld (hl), e
inc hl
ld (hl), d
inc hl
pop de ; number from stack pop de ; number from stack
call DEinHL ld (hl), e
ld (CMPDST), hl inc hl
ld (hl), d
inc hl
ld (HERE), hl
jp exit jp exit
; ( -- c ) ; ( -- c )
@ -333,9 +400,27 @@ 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 KEY .dw INTERPRET
CREATE: CREATE:
.dw nativeWord .dw nativeWord
call entryhead call entryhead
@ -389,21 +474,10 @@ 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 CSTORE .dw STORE
FETCH: FETCH:
.dw nativeWord .dw nativeWord
pop hl pop hl
@ -411,22 +485,10 @@ 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 CFETCH .dw FETCH
LITFETCH: LITFETCH:
.dw nativeWord .dw nativeWord
call readLITTOS call readLITTOS
@ -444,26 +506,10 @@ 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 SWAP2 .dw SWAP
DUP: DUP:
.dw nativeWord .dw nativeWord
pop hl pop hl
@ -471,24 +517,10 @@ 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 DUP2 .dw DUP
OVER: OVER:
.dw nativeWord .dw nativeWord
pop hl ; B pop hl ; B
@ -498,28 +530,10 @@ 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 OVER2 .dw OVER
PLUS: PLUS:
.dw nativeWord .dw nativeWord
pop hl pop hl
@ -593,63 +607,22 @@ CMP:
jp exit jp exit
.db "IF" .db "IF"
.fill 5 .fill 6
.db 1 ; IMMEDIATE
.dw CMP .dw CMP
IF: IF:
.dw nativeWord .dw ifWord
; 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 3 .fill 4
.db 1 ; IMMEDIATE
.dw IF .dw IF
ELSE: ELSE:
.dw nativeWord .dw elseWord
; 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 3 .fill 4
.db 1 ; IMMEDIATE
.dw ELSE .dw ELSE
THEN: THEN:
.dw nativeWord .dw thenWord
; 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
@ -663,5 +636,124 @@ RECURSE:
push hl \ pop iy push hl \ pop iy
jp compiledWord jp compiledWord
LATEST: ; End of native words
; ( a -- )
; @ .
.db "?"
.fill 7
.dw RECURSE .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
;

View File

@ -51,17 +51,12 @@ 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

View File

@ -12,39 +12,11 @@
.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:
@ -55,86 +27,19 @@ 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, HERE_INITIAL ld hl, FORTH_RAMEND
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 ix, RS_ADDR-2 ; -2 because we inc-before-push
ld (INPUTPOS), hl ld (INPUTPOS), hl
ld hl, COMPBUF
ld (CMPDST), hl
forthInterpret: forthInterpret:
call readword ld ix, RS_ADDR-2 ; -2 because we inc-before-push
jr nz, .execute ld iy, INTERPRET
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

View File

@ -25,17 +25,6 @@ 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)

View File

@ -69,28 +69,14 @@ HLPointsLIT:
pop de pop de
ret ret
HLPointsBRANCH: HLPointsEXITQUIT:
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
pop de jr z, .end
ret
HLPointsQUIT:
push de
ld de, QUIT ld de, QUIT
call HLPointsDE call HLPointsDE
.end:
pop de pop de
ret ret
@ -100,8 +86,6 @@ HLPointsQUIT:
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
@ -111,11 +95,7 @@ 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
@ -180,11 +160,7 @@ readLIT:
; it's a word. ; it's a word.
call HLPointsNUMBER call HLPointsNUMBER
jr z, .notWord jr z, .notWord
call HLPointsBRANCH call HLPointsEXITQUIT
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
@ -281,6 +257,42 @@ 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:
@ -303,8 +315,10 @@ 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
HLisIMMED: HLPointsIMMED:
push hl
call intoHL
dec hl dec hl
dec hl dec hl
dec hl dec hl
@ -315,13 +329,6 @@ HLisIMMED:
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
@ -336,10 +343,3 @@ 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
View File

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

View File

@ -24,25 +24,13 @@ 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/forth0.bin: forth/glue0.asm $(ZASMBIN) forth/forth.bin: forth/glue.asm $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null $(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
forth/forth0-bin.h: forth/forth0.bin forth/forth-bin.h: forth/forth.bin
./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null ./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h forth/forth: forth/forth.c $(OBJS) forth/forth-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

View File

@ -3,18 +3,17 @@
#include <unistd.h> #include <unistd.h>
#include <termios.h> #include <termios.h>
#include "../emul.h" #include "../emul.h"
#include "forth1-bin.h" #include "forth-bin.h"
// in sync with glue.asm // in sync with glue.asm
#define RAMSTART 0x900 #define RAMSTART 0x2000
#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 = getc(fp); int c = getchar();
if (c == EOF) { if (c == EOF) {
running = 0; running = 0;
} }
@ -32,17 +31,8 @@ static void iowr_stdio(uint8_t val)
int main(int argc, char *argv[]) int main(int argc, char *argv[])
{ {
bool tty = false; bool tty = isatty(fileno(stdin));
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) {
@ -53,10 +43,7 @@ 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;
@ -71,12 +58,11 @@ int main(int argc, char *argv[])
while (running && emul_step()); while (running && emul_step());
if (tty) { if (tty) {
printf("\nDone!\n"); printf("Done!\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;
} }

View File

@ -1,7 +1,5 @@
; 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
@ -24,7 +22,6 @@
.inc "forth/stack.asm" .inc "forth/stack.asm"
.inc "forth/dict.asm" .inc "forth/dict.asm"
init: init:
di di
; setup stack ; setup stack
@ -41,10 +38,3 @@ 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:

View File

@ -1,56 +0,0 @@
; 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,87 +0,0 @@
#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;
}