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

Compare commits

...

4 Commits

Author SHA1 Message Date
Virgil Dupras
94166186eb forth: fix DOES> bad exec offset 2020-03-13 21:27:19 -04:00
Virgil Dupras
5b1ca474d4 forth: Add word "("
Also, fix "RECURSE" in IMMEDIATE contexts.
2020-03-13 19:33:16 -04:00
Virgil Dupras
d60ea4cb30 forth: Forth-ify RECURSE
This comes with RS-modifying words. Also, this commit separates ";" from "EXIT",
allowing EXIT to be used in definitions (was needed for RECURSE).
2020-03-13 16:40:55 -04:00
Virgil Dupras
c3838714d5 forth: improve execution model
My approach with RS was slightly wrong: RS' TOP was always containing current
IP. It worked, but it was problematic when came the time to introduce
RS-modifying words: it's impossible to modify RS in a word without immediately
messing your flow.

Therefore, what used to be RS' TOS has to be a variable that isn't changed
midway by RS-modifying words. I guess that's why RS is called *return* stack...
2020-03-13 16:01:09 -04:00
9 changed files with 297 additions and 155 deletions

View File

@ -1,16 +1,26 @@
: H HERE @ ; : H HERE @ ;
: -^ SWAP - ; : -^ SWAP - ;
: ? @ . ;
: +! SWAP OVER @ + SWAP ! ; : +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ; : ALLOT HERE +! ;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE H ! DOES> @ ;
: , H ! 2 ALLOT ; : , H ! 2 ALLOT ;
: C, H C! 1 ALLOT ; : C, H C! 1 ALLOT ;
: IF ['] (fbr?) , H 0 C, ; IMMEDIATE : IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
: THEN DUP H -^ SWAP C! ; IMMEDIATE : THEN DUP H -^ SWAP C! ; IMMEDIATE
: ELSE ['] (fbr) , 0 C, DUP H -^ SWAP C! H 1 - ; IMMEDIATE : ELSE ['] (fbr) , 1 ALLOT DUP H -^ SWAP C! H 1 - ; IMMEDIATE
: RECURSE R> R> 2 - >R >R EXIT ;
: ( LIT@ ) WORD SCMP IF RECURSE THEN ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me? )
( Ah, voice at last! Some lines above need comments )
( IF: write (fbr?) addr, push HERE, create cell )
( THEN: Subtract TOS from H to get offset to write to cell )
( in that same TOS's addr )
( ELSE: write (fbr) addr, allot, then same as THEN )
( RECURSE: RS TOS is for RECURSE itself, then we have to dig )
( one more level to get to RECURSE's parent's caller. )
: NOT IF 0 ELSE 1 THEN ; : NOT IF 0 ELSE 1 THEN ;
: ? @ . ;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE H ! DOES> @ ;
: = CMP NOT ; : = CMP NOT ;
: < CMP 0 1 - = ; : < CMP 0 1 - = ;
: > CMP 1 = ; : > CMP 1 = ;

View File

@ -7,43 +7,64 @@
; ;
; The code pointer point to "word routines". These routines expect to be called ; 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 ; with IY pointing to the PF. They themselves are expected to end by jumping
; to the address at the top of the Return Stack. They will usually do so with ; to the address at (IP). They will usually do so with "jp next".
; "jp exit".
; ;
; That's for "regular" words (words that are part of the dict chain). There are ; That's for "regular" words (words that are part of the dict chain). There are
; also "special words", for example NUMBER, LIT, FBR, that have a slightly ; also "special words", for example NUMBER, LIT, FBR, that have a slightly
; different structure. They're also a pointer to an executable, but as for the ; different structure. They're also a pointer to an executable, but as for the
; other fields, the only one they have is the "flags" field. ; other fields, the only one they have is the "flags" field.
; This routine is jumped to at the end of every word. In it, we jump to current
; IP, but we also take care of increasing it my 2 before jumping
next:
; Before we continue: are stacks within bounds?
call chkPSRS
ld de, (IP)
ld h, d
ld l, e
inc de \ inc de
ld (IP), de
; HL is an atom list pointer. We need to go into it to have a wordref
ld e, (hl)
inc hl
ld d, (hl)
push de
jp EXECUTE+2
; Execute a word containing native code at its PF address (PFA) ; Execute a word containing native code at its PF address (PFA)
nativeWord: nativeWord:
jp (iy) jp (iy)
; Execute a list of atoms, which usually ends with EXIT. ; Execute a list of atoms, which always end with EXIT.
; IY points to that list. ; IY points to that list. What do we do:
; 1. Push current IP to RS
; 2. Set new IP to the second atom of the list
; 3. Execute the first atom of the list.
compiledWord: compiledWord:
ld hl, (IP)
call pushRS
push iy \ pop hl push iy \ pop hl
inc hl inc hl
inc hl inc hl
; HL points to next Interpreter pointer. ld (IP), hl
call pushRS ; IY still is our atom reference...
ld l, (iy) ld l, (iy)
ld h, (iy+1) ld h, (iy+1)
push hl \ pop iy push hl ; argument for EXECUTE
; IY points to code link jp EXECUTE+2
jp executeCodeLink
; Pushes the PFA directly ; Pushes the PFA directly
cellWord: cellWord:
push iy push iy
jp exit jp next
; Pushes the address in the first word of the PF ; Pushes the address in the first word of the PF
sysvarWord: sysvarWord:
ld l, (iy) ld l, (iy)
ld h, (iy+1) ld h, (iy+1)
push hl push hl
jp exit jp next
; The word was spawned from a definition word that has a DOES>. PFA+2 (right ; The word was spawned from a definition word that has a DOES>. PFA+2 (right
; after the actual cell) is a link to the slot right after that DOES>. ; after the actual cell) is a link to the slot right after that DOES>.
@ -59,20 +80,16 @@ doesWord:
; 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
; that number is to play with the Return stack: We pop it, read the number, push ; that number is to play with the IP.
; it to the Parameter stack and then push an increase Interpreter Pointer back
; to RS.
numberWord: numberWord:
ld l, (ix) ld hl, (IP) ; (HL) is out number
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 ld (IP), hl ; advance IP by 2
ld (ix+1), h
push de push de
jp exit jp next
.db 0b10 ; Flags .db 0b10 ; Flags
NUMBER: NUMBER:
@ -84,8 +101,7 @@ NUMBER:
; context. Only words expecting those literals will look for them. This is why ; context. Only words expecting those literals will look for them. This is why
; the litWord triggers abort. ; the litWord triggers abort.
litWord: litWord:
call popRS ld hl, (IP)
call intoHL
call printstr ; let's print the word before abort. call printstr ; let's print the word before abort.
ld hl, .msg ld hl, .msg
call printstr call printstr
@ -97,24 +113,17 @@ litWord:
LIT: LIT:
.dw litWord .dw litWord
; Pop previous IP from Return stack and execute it.
; ( R:I -- ) ; ( R:I -- )
.db ";" .db "EXIT"
.fill 7 .fill 3
.dw 0 .dw 0
.db 0
EXIT: EXIT:
.dw nativeWord .dw nativeWord
; When we call the EXIT word, we have to do a "double exit" because our current
; Interpreter pointer is pointing to the word *next* to our EXIT reference when,
; in fact, we want to continue processing the one above it.
call popRS call popRS
exit: ld (IP), hl
; Before we continue: is SP within bounds? jp next
call chkPS
; we're good
call popRS
; We have a pointer to a word
push hl \ pop iy
jp compiledWord
; ( R:I -- ) ; ( R:I -- )
.db "QUIT" .db "QUIT"
@ -133,9 +142,9 @@ quit:
ABORT: ABORT:
.dw nativeWord .dw nativeWord
abort: 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 forthRdLineNoOk
ABORTREF: ABORTREF:
.dw ABORT .dw ABORT
@ -163,7 +172,7 @@ EMIT:
pop hl pop hl
ld a, l ld a, l
call stdioPutC call stdioPutC
jp exit jp next
; ( c port -- ) ; ( c port -- )
.db "PC!" .db "PC!"
@ -175,7 +184,7 @@ PSTORE:
pop bc pop bc
pop hl pop hl
out (c), l out (c), l
jp exit jp next
; ( port -- c ) ; ( port -- c )
.db "PC@" .db "PC@"
@ -188,7 +197,7 @@ PFETCH:
ld h, 0 ld h, 0
in l, (c) in l, (c)
push hl push hl
jp exit jp next
; ( addr -- ) ; ( addr -- )
.db "EXECUTE" .db "EXECUTE"
@ -206,18 +215,24 @@ executeCodeLink:
; IY points to PFA ; IY points to PFA
jp (hl) ; go! jp (hl) ; go!
.db ";"
.fill 6
.dw EXECUTE
.db 0
ENDDEF:
.dw nativeWord
jp EXIT+2
.db ":" .db ":"
.fill 6 .fill 6
.dw EXECUTE .dw ENDDEF
.db 0 .db 0
DEFINE: DEFINE:
.dw nativeWord .dw nativeWord
call entryhead call entryhead
ld de, compiledWord ld de, compiledWord
ld (hl), e call DEinHL
inc hl
ld (hl), d
inc hl
; At this point, we've processed the name literal following the ':'. ; At this point, we've processed the name literal following the ':'.
; What's next? We have, in IP, a pointer to words that *have already ; What's next? We have, in IP, a pointer to words that *have already
; been compiled by INTERPRET*. All those bytes will be copied as-is. ; been compiled by INTERPRET*. All those bytes will be copied as-is.
@ -225,10 +240,12 @@ DEFINE:
; 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 (HERE), de ; update HERE
ld l, (ix) ld hl, (IP)
ld h, (ix+1)
.loop: .loop:
call HLPointsEXIT push de ; --> lvl 1
ld de, ENDDEF
call HLPointsDE
pop de ; <-- lvl 1
jr z, .loopend jr z, .loopend
call compSkip call compSkip
jr .loop jr .loop
@ -236,22 +253,19 @@ DEFINE:
; skip EXIT ; skip EXIT
inc hl \ inc hl inc hl \ inc hl
; We have out end offset. Let's get our offset ; We have out end offset. Let's get our offset
ld e, (ix) ld de, (IP)
ld d, (ix+1)
or a ; clear carry or a ; clear carry
sbc hl, de sbc hl, de
; HL is our copy count. ; HL is our copy count.
ld b, h ld b, h
ld c, l ld c, l
ld l, (ix) ld hl, (IP)
ld h, (ix+1)
ld de, (HERE) ; recall dest ld de, (HERE) ; recall dest
; copy! ; copy!
ldir ldir
ld (ix), l ld (IP), hl
ld (ix+1), h
ld (HERE), de ld (HERE), de
jp exit jp next
.db "DOES>" .db "DOES>"
@ -264,18 +278,16 @@ DOES:
; need to do. ; need to do.
; 1. Change the code link to doesWord ; 1. Change the code link to doesWord
; 2. Leave 2 bytes for regular cell variable. ; 2. Leave 2 bytes for regular cell variable.
; 3. Get the Interpreter pointer from the stack and write this down to ; 3. Write down IP+2 to entry.
; entry PFA+2. ; 3. exit. we're done here.
; 3. exit. Because we've already popped RS, a regular exit will abort
; colon definition, so we're good.
ld iy, (CURRENT) ld iy, (CURRENT)
ld hl, doesWord ld hl, doesWord
call wrCompHL call wrCompHL
inc iy \ inc iy ; cell variable space inc iy \ inc iy ; cell variable space
call popRS ld hl, (IP)
call wrCompHL call wrCompHL
ld (HERE), iy ld (HERE), iy
jp exit jp EXIT+2
.db "IMMEDIA" .db "IMMEDIA"
@ -286,7 +298,7 @@ IMMEDIATE:
ld hl, (CURRENT) ld hl, (CURRENT)
dec hl dec hl
set FLAG_IMMED, (hl) set FLAG_IMMED, (hl)
jp exit jp next
; ( n -- ) ; ( n -- )
.db "LITERAL" .db "LITERAL"
@ -300,7 +312,7 @@ LITERAL:
pop de ; number from stack pop de ; number from stack
call DEinHL call DEinHL
ld (HERE), hl ld (HERE), hl
jp exit jp next
.db "'" .db "'"
@ -313,7 +325,7 @@ APOS:
call find call find
jr nz, .notfound jr nz, .notfound
push de push de
jp exit jp next
.notfound: .notfound:
ld hl, .msg ld hl, .msg
call printstr call printstr
@ -337,7 +349,7 @@ APOSI:
pop de ; <-- lvl 1 pop de ; <-- lvl 1
call DEinHL call DEinHL
ld (HERE), hl ld (HERE), hl
jp exit jp next
.notfound: .notfound:
ld hl, .msg ld hl, .msg
call printstr call printstr
@ -356,23 +368,33 @@ KEY:
ld h, 0 ld h, 0
ld l, a ld l, a
push hl push hl
jp exit jp next
.db "WORD"
.fill 3
.dw KEY
.db 0
WORD:
.dw nativeWord
call readword
jp nz, abort
push hl
jp next
.db "CREATE" .db "CREATE"
.fill 1 .fill 1
.dw KEY .dw WORD
.db 0 .db 0
CREATE: CREATE:
.dw nativeWord .dw nativeWord
call entryhead call entryhead
jp nz, quit
ld de, cellWord ld de, cellWord
ld (hl), e ld (hl), e
inc hl inc hl
ld (hl), d ld (hl), d
inc hl inc hl
ld (HERE), hl ld (HERE), hl
jp exit jp next
.db "HERE" .db "HERE"
.fill 3 .fill 3
@ -399,11 +421,11 @@ DOT:
pop de pop de
; We check PS explicitly because it doesn't look nice to spew gibberish ; We check PS explicitly because it doesn't look nice to spew gibberish
; before aborting the stack underflow. ; before aborting the stack underflow.
call chkPS call chkPSRS
call pad call pad
call fmtDecimalS call fmtDecimalS
call printstr call printstr
jp exit jp next
; ( n a -- ) ; ( n a -- )
.db "!" .db "!"
@ -416,7 +438,7 @@ STORE:
pop hl pop hl
ld (iy), l ld (iy), l
ld (iy+1), h ld (iy+1), h
jp exit jp next
; ( n a -- ) ; ( n a -- )
.db "C!" .db "C!"
@ -428,7 +450,7 @@ CSTORE:
pop hl pop hl
pop de pop de
ld (hl), e ld (hl), e
jp exit jp next
; ( a -- n ) ; ( a -- n )
.db "@" .db "@"
@ -440,7 +462,7 @@ FETCH:
pop hl pop hl
call intoHL call intoHL
push hl push hl
jp exit jp next
; ( a -- c ) ; ( a -- c )
.db "C@" .db "C@"
@ -453,9 +475,8 @@ CFETCH:
ld l, (hl) ld l, (hl)
ld h, 0 ld h, 0
push hl push hl
jp exit jp next
; ( -- a )
.db "LIT@" .db "LIT@"
.fill 3 .fill 3
.dw CFETCH .dw CFETCH
@ -464,7 +485,7 @@ LITFETCH:
.dw nativeWord .dw nativeWord
call readLITTOS call readLITTOS
push hl push hl
jp exit jp next
; ( a b -- b a ) ; ( a b -- b a )
.db "SWAP" .db "SWAP"
@ -476,7 +497,7 @@ SWAP:
pop hl pop hl
ex (sp), hl ex (sp), hl
push hl push hl
jp exit jp next
; ( a b c d -- c d a b ) ; ( a b c d -- c d a b )
.db "2SWAP" .db "2SWAP"
@ -493,7 +514,7 @@ SWAP2:
push de ; D push de ; D
push hl ; A push hl ; A
push bc ; B push bc ; B
jp exit jp next
; ( a -- a a ) ; ( a -- a a )
.db "DUP" .db "DUP"
@ -505,7 +526,7 @@ DUP:
pop hl pop hl
push hl push hl
push hl push hl
jp exit jp next
; ( a b -- a b a b ) ; ( a b -- a b a b )
.db "2DUP" .db "2DUP"
@ -520,7 +541,7 @@ DUP2:
push hl push hl
push de push de
push hl push hl
jp exit jp next
; ( a b -- a b a ) ; ( a b -- a b a )
.db "OVER" .db "OVER"
@ -534,7 +555,7 @@ OVER:
push de push de
push hl push hl
push de push de
jp exit jp next
; ( a b c d -- a b c d a b ) ; ( a b c d -- a b c d a b )
.db "2OVER" .db "2OVER"
@ -553,12 +574,65 @@ OVER2:
push hl ; D push hl ; D
push iy ; A push iy ; A
push bc ; B push bc ; B
jp exit jp next
.db ">R"
.fill 5
.dw OVER2
.db 0
P2R:
.dw nativeWord
pop hl
call pushRS
jp next
.db "R>"
.fill 5
.dw P2R
.db 0
R2P:
.dw nativeWord
call popRS
push hl
jp next
.db "I"
.fill 6
.dw R2P
.db 0
I:
.dw nativeWord
ld l, (ix)
ld h, (ix+1)
push hl
jp next
.db "I'"
.fill 5
.dw I
.db 0
IPRIME:
.dw nativeWord
ld l, (ix-2)
ld h, (ix-1)
push hl
jp next
.db "J"
.fill 6
.dw IPRIME
.db 0
J:
.dw nativeWord
ld l, (ix-4)
ld h, (ix-3)
push hl
jp next
; ( a b -- c ) A + B ; ( a b -- c ) A + B
.db "+" .db "+"
.fill 6 .fill 6
.dw OVER2 .dw J
.db 0 .db 0
PLUS: PLUS:
.dw nativeWord .dw nativeWord
@ -566,7 +640,7 @@ PLUS:
pop de pop de
add hl, de add hl, de
push hl push hl
jp exit jp next
; ( a b -- c ) A - B ; ( a b -- c ) A - B
.db "-" .db "-"
@ -580,7 +654,7 @@ MINUS:
or a ; reset carry or a ; reset carry
sbc hl, de sbc hl, de
push hl push hl
jp exit jp next
; ( a b -- c ) A * B ; ( a b -- c ) A * B
.db "*" .db "*"
@ -593,7 +667,7 @@ MULT:
pop bc pop bc
call multDEBC call multDEBC
push hl push hl
jp exit jp next
; ( a b -- c ) A / B ; ( a b -- c ) A / B
.db "/" .db "/"
@ -606,7 +680,7 @@ DIV:
pop hl pop hl
call divide call divide
push bc push bc
jp exit jp next
; ( a1 a2 -- b ) ; ( a1 a2 -- b )
.db "SCMP" .db "SCMP"
@ -620,7 +694,7 @@ SCMP:
call strcmp call strcmp
call flagsToBC call flagsToBC
push bc push bc
jp exit jp next
; ( n1 n2 -- f ) ; ( n1 n2 -- f )
.db "CMP" .db "CMP"
@ -635,7 +709,7 @@ CMP:
sbc hl, de sbc hl, de
call flagsToBC call flagsToBC
push bc push bc
jp exit jp next
; This word's atom is followed by 1b *relative* offset (to the cell's addr) to ; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
; where to branch to. For example, The branching cell of "IF THEN" would ; where to branch to. For example, The branching cell of "IF THEN" would
@ -647,14 +721,12 @@ CMP:
FBR: FBR:
.dw nativeWord .dw nativeWord
push de push de
ld l, (ix) ld hl, (IP)
ld h, (ix+1)
ld a, (hl) ld a, (hl)
call addHL call addHL
ld (ix), l ld (IP), hl
ld (ix+1), h
pop de pop de
jp exit jp next
; Conditional branch, only branch if TOS is zero ; Conditional branch, only branch if TOS is zero
.db "(fbr?)" .db "(fbr?)"
@ -668,25 +740,11 @@ FBRC:
or l or l
jr z, FBR+2 jr z, FBR+2
; skip next byte in RS ; skip next byte in RS
ld l, (ix) ld hl, (IP)
ld h, (ix+1)
inc hl inc hl
ld (ix), l ld (IP), hl
ld (ix+1), h jp next
jp exit
.db "RECURSE"
.dw FBRC
.db 0
RECURSE:
.dw nativeWord
call popRS
ld l, (ix)
ld h, (ix+1)
dec hl \ dec hl
push hl \ pop iy
jp compiledWord
LATEST: LATEST:
.dw RECURSE .dw FBRC

View File

@ -36,7 +36,9 @@ directly, but as part of another word.
; R:I -- Exit a colon definition ; R:I -- Exit a colon definition
, n -- Write n in HERE and advance it. , n -- Write n in HERE and advance it.
' x -- a Push addr of word x to a. ' x -- a Push addr of word x to a.
['] x -- *I* Like "'", but spits the addr as a number literal. ['] x -- *I* Like "'", but spits the addr as a number
literal.
( -- *I* Comment. Ignore rest of line until ")" is read.
ALLOT n -- Move HERE by n bytes ALLOT n -- Move HERE by n bytes
C, b -- Write byte b in HERE and advance it. C, b -- Write byte b in HERE and advance it.
CREATE x -- Create cell named x. Doesn't allocate a PF. CREATE x -- Create cell named x. Doesn't allocate a PF.
@ -60,7 +62,7 @@ QUIT R:drop -- Return to interpreter promp immediately
RECURSE R:I -- R:I-2 Run the current word again. RECURSE R:I -- R:I-2 Run the current word again.
THEN I:a -- *I* Set branching cell at a. THEN I:a -- *I* Set branching cell at a.
*** Stack *** *** Parameter Stack ***
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
@ -68,6 +70,13 @@ SWAP a b -- b a
2OVER a b c d -- a b c d a b 2OVER a b c d -- a b c d a b
2SWAP a b c d -- c d a b 2SWAP a b c d -- c d a b
*** Return Stack ***
>R n -- R:n Pops PS and push to RS
R> R:n -- n Pops RS and push to PS
I -- n Copy RS TOS to PS
I' -- n Copy RS second item to PS
J -- n Copy RS third item to PS
*** 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
@ -75,7 +84,7 @@ SWAP a b -- b 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@ a -- c Set c to byte at address a
C! c a -- Store byte c in address a C! c a -- Store byte c in address a
CURRENT -- n Set n to wordref of last added entry. CURRENT -- a Set a to wordref of last added entry.
HERE -- a Push HERE's address HERE -- a Push HERE's address
H -- a HERE @ H -- a HERE @
@ -96,8 +105,8 @@ CMP n1 n2 -- n Compare n1 and n2 and set n to -1, 0, or 1.
NOT f -- f Push the logical opposite of f NOT f -- f Push the logical opposite of f
*** Strings *** *** Strings ***
LIT@ x -- a Read folloing LIT and push its addr to a LIT@ x -- a Read following LIT and push its addr to a
S= a1 a2 -- n Compare strings a1 and a2. See CMP SCMP a1 a2 -- n Compare strings a1 and a2. See CMP
*** I/O *** *** I/O ***
. n -- Print n in its decimal form . n -- Print n in its decimal form
@ -105,4 +114,5 @@ EMIT c -- Spit char c to stdout
KEY -- c Get char c from stdin KEY -- c Get char c from stdin
PC! c a -- Spit c to port a PC! c a -- Spit c to port a
PC@ a -- c Fetch c from port a PC@ a -- c Fetch c from port a
WORD -- a Read one word from stdin and push its addr

View File

@ -17,9 +17,15 @@
; *** Variables *** ; *** Variables ***
.equ INITIAL_SP FORTH_RAMSTART .equ INITIAL_SP FORTH_RAMSTART
; wordref of the last entry of the dict.
.equ CURRENT @+2 .equ CURRENT @+2
; Pointer to the next free byte in dict. During compilation of input text, this
; temporarily points to the next free byte in COMPBUF.
.equ HERE @+2 .equ HERE @+2
; Used to hold HERE while we temporarily point it to COMPBUF
.equ OLDHERE @+2 .equ OLDHERE @+2
; Interpreter pointer. See Execution model comment below.
.equ IP @+2
; Pointer to where we currently are in the interpretation of the current line. ; Pointer to where we currently are in the interpretation of the current line.
.equ INPUTPOS @+2 .equ INPUTPOS @+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.
@ -59,6 +65,23 @@
; ;
; During IMMEDIATE mode, (HERE) is temporarily set to COMPBUF, and when we're ; During IMMEDIATE mode, (HERE) is temporarily set to COMPBUF, and when we're
; done, we restore (HERE) for runtime. This way, everyone is happy. ; done, we restore (HERE) for runtime. This way, everyone is happy.
;
; EXECUTING A WORD
;
; At it's core, executing a word is having the wordref in IY and call
; executeCodeLink. Then, we let the word do its things. Some words are special,
; but most of them are of the compiledWord type, and that's their execution that
; we describe here.
;
; First of all, at all time during execution, the Interpreter Pointer (IP)
; points to the wordref we're executing next.
;
; When we execute a compiledWord, the first thing we do is push IP to the Return
; Stack (RS). Therefore, RS' top of stack will contain a wordref to execute
; next, after we EXIT.
;
; At the end of every compiledWord is an EXIT. This pops RS, sets IP to it, and
; continues.
; *** Code *** ; *** Code ***
forthMain: forthMain:
@ -82,10 +105,14 @@ forthMain:
forthRdLine: forthRdLine:
ld hl, msgOk ld hl, msgOk
call printstr call printstr
forthRdLineNoOk:
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
; Setup return stack. As a safety net, we set its bottom to ABORTREF.
ld hl, ABORTREF
ld (RS_ADDR), hl
ld ix, RS_ADDR
; We're about to compile the line and possibly execute IMMEDIATE words. ; We're about to compile the line and possibly execute IMMEDIATE words.
; Let's save current (HERE) and temporarily set it to COMPBUF. ; Let's save current (HERE) and temporarily set it to COMPBUF.
ld hl, (HERE) ld hl, (HERE)
@ -128,11 +155,17 @@ forthInterpret:
ld (HERE), de ld (HERE), de
jr forthInterpret jr forthInterpret
.immed: .immed:
push hl ; --> lvl 1 ; For this IMMEDIATE word to be compatible with regular execution model,
ld hl, .retRef ; it needs to be compiled as an atom list. We need a temporary space for
call pushRS ; this, let's use (OLDHERE) while it isn't used.
pop iy ; <-- lvl 1 ex de, hl ; atom to write in DE
jp executeCodeLink ld hl, (OLDHERE)
call DEinHL
; Now, let's write the .retRef
ld de, .retRef
call DEinHL
ld iy, (OLDHERE)
jr .execIY
.execute: .execute:
ld de, QUIT ld de, QUIT
call .writeDE call .writeDE
@ -140,23 +173,25 @@ forthInterpret:
ld hl, (OLDHERE) ld hl, (OLDHERE)
ld (HERE), hl ld (HERE), hl
ld iy, COMPBUF ld iy, COMPBUF
.execIY:
; before we execute, let's play with our RS a bit: compiledWord is
; going to push (IP) on the RS, but we don't expect our compiled words
; to ever return: it ends with QUIT. Let's set (IP) to ABORTREF and
; IX to RS_ADDR-2 so that compiledWord re-pushes our safety net.
ld hl, ABORTREF
ld (IP), hl
ld ix, RS_ADDR-2
jp compiledWord jp compiledWord
.writeDE: .writeDE:
push hl push hl
ld hl, (HERE) ld hl, (HERE)
ld (hl), e call DEinHL
inc hl
ld (hl), d
inc hl
ld (HERE), hl ld (HERE), hl
pop hl pop hl
ret ret
.retRef: .retRef:
.dw $+2 .dw forthInterpret
.dw $+2
call popRS
jr forthInterpret
msgOk: msgOk:
.db " ok", 0 .db " ok", 0

View File

@ -36,8 +36,15 @@ skipRS:
pop hl pop hl
ret ret
; Verifies that SP is within bounds. If it's not, call ABORT ; Verifies that SP and RS are within bounds. If it's not, call ABORT
chkPS: chkPSRS:
push ix \ pop hl
push de ; --> lvl 1
ld de, RS_ADDR
or a ; clear carry
sbc hl, de
pop de ; <-- lvl 1
jr c, .underflow
ld hl, (INITIAL_SP) ld hl, (INITIAL_SP)
; We have the return address for this very call on the stack. Let's ; We have the return address for this very call on the stack. Let's
; compensate ; compensate
@ -45,6 +52,7 @@ chkPS:
or a ; clear carry or a ; clear carry
sbc hl, sp sbc hl, sp
ret nc ; (INITIAL_SP) >= SP? good ret nc ; (INITIAL_SP) >= SP? good
.underflow:
; underflow ; underflow
ld hl, .msg ld hl, .msg
call printstr call printstr

View File

@ -80,13 +80,6 @@ HLPointsBR:
pop de pop de
ret ret
HLPointsEXIT:
push de
ld de, EXIT
call HLPointsDE
pop de
ret
; Skip the compword where HL is currently pointing. If it's a regular word, ; Skip the compword where HL is currently pointing. If it's a regular word,
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip ; 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. ; to after null-termination.
@ -202,20 +195,31 @@ readLIT:
.db "word expected", 0 .db "word expected", 0
readLITBOS: readLITBOS:
; Before we start: is our RS empty? If IX == RS_ADDR, it is (it only has
; its safety net). When that happens, we actually want to run readLITTOS
push hl
push de push de
ld hl, (RS_ADDR) push ix \ pop hl
ld de, RS_ADDR
or a ; clear carry
sbc hl, de
pop de
pop hl
jr z, readLITTOS
push de
; Our bottom-of-stack is RS_ADDR+2 because RS_ADDR is occupied by our
; ABORTREF safety net.
ld hl, (RS_ADDR+2)
call readLIT call readLIT
ld (RS_ADDR), de ld (RS_ADDR+2), de
pop de pop de
ret ret
readLITTOS: readLITTOS:
push de push de
ld l, (ix) ld hl, (IP)
ld h, (ix+1)
call readLIT call readLIT
ld (ix), e ld (IP), de
ld (ix+1), d
pop de pop de
ret ret
@ -284,7 +288,6 @@ entryhead:
inc hl inc hl
ld (CURRENT), hl ld (CURRENT), hl
ld (HERE), hl ld (HERE), hl
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

1
emul/.gitignore vendored
View File

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

View File

@ -33,6 +33,9 @@ forth/forth0-bin.h: forth/forth0.bin
forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h
$(CC) forth/stage1.c $(OBJS) -o $@ $(CC) forth/stage1.c $(OBJS) -o $@
forth/stage1dbg: forth/stage1.c $(OBJS) forth/forth0-bin.h
$(CC) -DDEBUG forth/stage1.c $(OBJS) -o $@
forth/core.bin: $(APPS)/forth/core.fth forth/stage1 forth/core.bin: $(APPS)/forth/core.fth forth/stage1
./forth/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null ./forth/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null

View File

@ -20,6 +20,11 @@ directly follow executable's last byte so that we don't waste spce and also
that wordref offsets correspond. that wordref offsets correspond.
*/ */
// When DEBUG is set, stage1 is a core-less forth that works interactively.
// Useful for... debugging!
// By the way: there's a double-echo in stagedbg. It's normal. Don't panic.
//#define DEBUG
// in sync with glue.asm // in sync with glue.asm
#define RAMSTART 0x900 #define RAMSTART 0x900
#define STDIO_PORT 0x00 #define STDIO_PORT 0x00
@ -44,11 +49,17 @@ static uint8_t iord_stdio()
static void iowr_stdio(uint8_t val) static void iowr_stdio(uint8_t val)
{ {
// we don't output stdout in stage0 // we don't output stdout in stage0
#ifdef DEBUG
// ... unless we're in DEBUG mode!
putchar(val);
#endif
} }
int main(int argc, char *argv[]) int main(int argc, char *argv[])
{ {
bool tty = false; #ifdef DEBUG
fp = stdin;
#else
if (argc == 2) { if (argc == 2) {
fp = fopen(argv[1], "r"); fp = fopen(argv[1], "r");
if (fp == NULL) { if (fp == NULL) {
@ -59,6 +70,7 @@ int main(int argc, char *argv[])
fprintf(stderr, "Usage: ./stage0 filename\n"); fprintf(stderr, "Usage: ./stage0 filename\n");
return 1; return 1;
} }
#endif
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;
@ -74,6 +86,7 @@ int main(int argc, char *argv[])
fclose(fp); fclose(fp);
#ifndef DEBUG
// We're done, now let's spit dict data // We're done, now let's spit dict data
// let's start with LATEST spitting. // let's start with LATEST spitting.
putchar(m->mem[CURRENT]); putchar(m->mem[CURRENT]);
@ -82,6 +95,7 @@ int main(int argc, char *argv[])
for (int i=sizeof(KERNEL); i<here; i++) { for (int i=sizeof(KERNEL); i<here; i++) {
putchar(m->mem[i]); putchar(m->mem[i]);
} }
#endif
return 0; return 0;
} }