mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 16:20:55 +11:00
Compare commits
No commits in common. "94166186ebeeb2692e83343617e7d6a5e969e34e" and "d0d92a45599aeb6cef7ceec1cbf73c3772260009" have entirely different histories.
94166186eb
...
d0d92a4559
@ -1,26 +1,16 @@
|
||||
: H HERE @ ;
|
||||
: -^ SWAP - ;
|
||||
: ? @ . ;
|
||||
: +! SWAP OVER @ + SWAP ! ;
|
||||
: ALLOT HERE +! ;
|
||||
: , H ! 2 ALLOT ;
|
||||
: C, H C! 1 ALLOT ;
|
||||
: IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
|
||||
: THEN DUP H -^ SWAP C! ; 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 ;
|
||||
: ? @ . ;
|
||||
: VARIABLE CREATE 2 ALLOT ;
|
||||
: CONSTANT CREATE H ! DOES> @ ;
|
||||
: , H ! 2 ALLOT ;
|
||||
: C, H C! 1 ALLOT ;
|
||||
: IF ['] (fbr?) , H 0 C, ; IMMEDIATE
|
||||
: THEN DUP H -^ SWAP C! ; IMMEDIATE
|
||||
: ELSE ['] (fbr) , 0 C, DUP H -^ SWAP C! H 1 - ; IMMEDIATE
|
||||
: NOT IF 0 ELSE 1 THEN ;
|
||||
: = CMP NOT ;
|
||||
: < CMP 0 1 - = ;
|
||||
: > CMP 1 = ;
|
||||
|
||||
@ -7,64 +7,43 @@
|
||||
;
|
||||
; The code pointer point to "word routines". These routines expect to be called
|
||||
; with IY pointing to the PF. They themselves are expected to end by jumping
|
||||
; to the address at (IP). They will usually do so with "jp next".
|
||||
; to the address at the top of the Return Stack. They will usually do so with
|
||||
; "jp exit".
|
||||
;
|
||||
; 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
|
||||
; 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.
|
||||
|
||||
; 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)
|
||||
nativeWord:
|
||||
jp (iy)
|
||||
|
||||
; Execute a list of atoms, which always end with EXIT.
|
||||
; 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.
|
||||
; Execute a list of atoms, which usually ends with EXIT.
|
||||
; IY points to that list.
|
||||
compiledWord:
|
||||
ld hl, (IP)
|
||||
call pushRS
|
||||
push iy \ pop hl
|
||||
inc hl
|
||||
inc hl
|
||||
ld (IP), hl
|
||||
; IY still is our atom reference...
|
||||
; HL points to next Interpreter pointer.
|
||||
call pushRS
|
||||
ld l, (iy)
|
||||
ld h, (iy+1)
|
||||
push hl ; argument for EXECUTE
|
||||
jp EXECUTE+2
|
||||
push hl \ pop iy
|
||||
; IY points to code link
|
||||
jp executeCodeLink
|
||||
|
||||
; Pushes the PFA directly
|
||||
cellWord:
|
||||
push iy
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; Pushes the address in the first word of the PF
|
||||
sysvarWord:
|
||||
ld l, (iy)
|
||||
ld h, (iy+1)
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; 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>.
|
||||
@ -80,16 +59,20 @@ doesWord:
|
||||
; This is not a word, but a number literal. This works a bit differently than
|
||||
; others: PF means nothing and the actual number is placed next to the
|
||||
; numberWord reference in the compiled word list. What we need to do to fetch
|
||||
; that number is to play with the IP.
|
||||
; that number is to play with the Return stack: We pop it, read the number, push
|
||||
; it to the Parameter stack and then push an increase Interpreter Pointer back
|
||||
; to RS.
|
||||
numberWord:
|
||||
ld hl, (IP) ; (HL) is out number
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
ld e, (hl)
|
||||
inc hl
|
||||
ld d, (hl)
|
||||
inc hl
|
||||
ld (IP), hl ; advance IP by 2
|
||||
ld (ix), l
|
||||
ld (ix+1), h
|
||||
push de
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
.db 0b10 ; Flags
|
||||
NUMBER:
|
||||
@ -101,7 +84,8 @@ NUMBER:
|
||||
; context. Only words expecting those literals will look for them. This is why
|
||||
; the litWord triggers abort.
|
||||
litWord:
|
||||
ld hl, (IP)
|
||||
call popRS
|
||||
call intoHL
|
||||
call printstr ; let's print the word before abort.
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
@ -113,17 +97,24 @@ litWord:
|
||||
LIT:
|
||||
.dw litWord
|
||||
|
||||
; Pop previous IP from Return stack and execute it.
|
||||
; ( R:I -- )
|
||||
.db "EXIT"
|
||||
.fill 3
|
||||
.dw 0
|
||||
.db 0
|
||||
.db ";"
|
||||
.fill 7
|
||||
.dw 0
|
||||
EXIT:
|
||||
.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
|
||||
ld (IP), hl
|
||||
jp next
|
||||
exit:
|
||||
; Before we continue: is SP within bounds?
|
||||
call chkPS
|
||||
; we're good
|
||||
call popRS
|
||||
; We have a pointer to a word
|
||||
push hl \ pop iy
|
||||
jp compiledWord
|
||||
|
||||
; ( R:I -- )
|
||||
.db "QUIT"
|
||||
@ -142,9 +133,9 @@ quit:
|
||||
ABORT:
|
||||
.dw nativeWord
|
||||
abort:
|
||||
; Reinitialize PS (RS is reinitialized in forthInterpret)
|
||||
; Reinitialize PS (RS is reinitialized in forthInterpret
|
||||
ld sp, (INITIAL_SP)
|
||||
jp forthRdLineNoOk
|
||||
jp forthRdLine
|
||||
ABORTREF:
|
||||
.dw ABORT
|
||||
|
||||
@ -172,7 +163,7 @@ EMIT:
|
||||
pop hl
|
||||
ld a, l
|
||||
call stdioPutC
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( c port -- )
|
||||
.db "PC!"
|
||||
@ -184,7 +175,7 @@ PSTORE:
|
||||
pop bc
|
||||
pop hl
|
||||
out (c), l
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( port -- c )
|
||||
.db "PC@"
|
||||
@ -197,7 +188,7 @@ PFETCH:
|
||||
ld h, 0
|
||||
in l, (c)
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( addr -- )
|
||||
.db "EXECUTE"
|
||||
@ -215,24 +206,18 @@ executeCodeLink:
|
||||
; IY points to PFA
|
||||
jp (hl) ; go!
|
||||
|
||||
|
||||
.db ";"
|
||||
.fill 6
|
||||
.dw EXECUTE
|
||||
.db 0
|
||||
ENDDEF:
|
||||
.dw nativeWord
|
||||
jp EXIT+2
|
||||
|
||||
.db ":"
|
||||
.fill 6
|
||||
.dw ENDDEF
|
||||
.dw EXECUTE
|
||||
.db 0
|
||||
DEFINE:
|
||||
.dw nativeWord
|
||||
call entryhead
|
||||
ld de, compiledWord
|
||||
call DEinHL
|
||||
ld (hl), e
|
||||
inc hl
|
||||
ld (hl), d
|
||||
inc hl
|
||||
; 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
|
||||
; been compiled by INTERPRET*. All those bytes will be copied as-is.
|
||||
@ -240,12 +225,10 @@ DEFINE:
|
||||
; skip compwords until EXIT is reached.
|
||||
ex de, hl ; DE is our dest
|
||||
ld (HERE), de ; update HERE
|
||||
ld hl, (IP)
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
.loop:
|
||||
push de ; --> lvl 1
|
||||
ld de, ENDDEF
|
||||
call HLPointsDE
|
||||
pop de ; <-- lvl 1
|
||||
call HLPointsEXIT
|
||||
jr z, .loopend
|
||||
call compSkip
|
||||
jr .loop
|
||||
@ -253,19 +236,22 @@ DEFINE:
|
||||
; skip EXIT
|
||||
inc hl \ inc hl
|
||||
; We have out end offset. Let's get our offset
|
||||
ld de, (IP)
|
||||
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 hl, (IP)
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
ld de, (HERE) ; recall dest
|
||||
; copy!
|
||||
ldir
|
||||
ld (IP), hl
|
||||
ld (ix), l
|
||||
ld (ix+1), h
|
||||
ld (HERE), de
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
|
||||
.db "DOES>"
|
||||
@ -278,16 +264,18 @@ DOES:
|
||||
; need to do.
|
||||
; 1. Change the code link to doesWord
|
||||
; 2. Leave 2 bytes for regular cell variable.
|
||||
; 3. Write down IP+2 to entry.
|
||||
; 3. exit. we're done here.
|
||||
; 3. Get the Interpreter pointer from the stack and write this down to
|
||||
; entry PFA+2.
|
||||
; 3. exit. Because we've already popped RS, a regular exit will abort
|
||||
; colon definition, so we're good.
|
||||
ld iy, (CURRENT)
|
||||
ld hl, doesWord
|
||||
call wrCompHL
|
||||
inc iy \ inc iy ; cell variable space
|
||||
ld hl, (IP)
|
||||
call popRS
|
||||
call wrCompHL
|
||||
ld (HERE), iy
|
||||
jp EXIT+2
|
||||
jp exit
|
||||
|
||||
|
||||
.db "IMMEDIA"
|
||||
@ -298,7 +286,7 @@ IMMEDIATE:
|
||||
ld hl, (CURRENT)
|
||||
dec hl
|
||||
set FLAG_IMMED, (hl)
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( n -- )
|
||||
.db "LITERAL"
|
||||
@ -312,7 +300,7 @@ LITERAL:
|
||||
pop de ; number from stack
|
||||
call DEinHL
|
||||
ld (HERE), hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
|
||||
.db "'"
|
||||
@ -325,7 +313,7 @@ APOS:
|
||||
call find
|
||||
jr nz, .notfound
|
||||
push de
|
||||
jp next
|
||||
jp exit
|
||||
.notfound:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
@ -349,7 +337,7 @@ APOSI:
|
||||
pop de ; <-- lvl 1
|
||||
call DEinHL
|
||||
ld (HERE), hl
|
||||
jp next
|
||||
jp exit
|
||||
.notfound:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
@ -368,33 +356,23 @@ KEY:
|
||||
ld h, 0
|
||||
ld l, a
|
||||
push hl
|
||||
jp next
|
||||
|
||||
.db "WORD"
|
||||
.fill 3
|
||||
.dw KEY
|
||||
.db 0
|
||||
WORD:
|
||||
.dw nativeWord
|
||||
call readword
|
||||
jp nz, abort
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
.db "CREATE"
|
||||
.fill 1
|
||||
.dw WORD
|
||||
.dw KEY
|
||||
.db 0
|
||||
CREATE:
|
||||
.dw nativeWord
|
||||
call entryhead
|
||||
jp nz, quit
|
||||
ld de, cellWord
|
||||
ld (hl), e
|
||||
inc hl
|
||||
ld (hl), d
|
||||
inc hl
|
||||
ld (HERE), hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
.db "HERE"
|
||||
.fill 3
|
||||
@ -421,11 +399,11 @@ DOT:
|
||||
pop de
|
||||
; We check PS explicitly because it doesn't look nice to spew gibberish
|
||||
; before aborting the stack underflow.
|
||||
call chkPSRS
|
||||
call chkPS
|
||||
call pad
|
||||
call fmtDecimalS
|
||||
call printstr
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( n a -- )
|
||||
.db "!"
|
||||
@ -438,7 +416,7 @@ STORE:
|
||||
pop hl
|
||||
ld (iy), l
|
||||
ld (iy+1), h
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( n a -- )
|
||||
.db "C!"
|
||||
@ -450,7 +428,7 @@ CSTORE:
|
||||
pop hl
|
||||
pop de
|
||||
ld (hl), e
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a -- n )
|
||||
.db "@"
|
||||
@ -462,7 +440,7 @@ FETCH:
|
||||
pop hl
|
||||
call intoHL
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a -- c )
|
||||
.db "C@"
|
||||
@ -475,8 +453,9 @@ CFETCH:
|
||||
ld l, (hl)
|
||||
ld h, 0
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( -- a )
|
||||
.db "LIT@"
|
||||
.fill 3
|
||||
.dw CFETCH
|
||||
@ -485,7 +464,7 @@ LITFETCH:
|
||||
.dw nativeWord
|
||||
call readLITTOS
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- b a )
|
||||
.db "SWAP"
|
||||
@ -497,7 +476,7 @@ SWAP:
|
||||
pop hl
|
||||
ex (sp), hl
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b c d -- c d a b )
|
||||
.db "2SWAP"
|
||||
@ -514,7 +493,7 @@ SWAP2:
|
||||
push de ; D
|
||||
push hl ; A
|
||||
push bc ; B
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a -- a a )
|
||||
.db "DUP"
|
||||
@ -526,7 +505,7 @@ DUP:
|
||||
pop hl
|
||||
push hl
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- a b a b )
|
||||
.db "2DUP"
|
||||
@ -541,7 +520,7 @@ DUP2:
|
||||
push hl
|
||||
push de
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- a b a )
|
||||
.db "OVER"
|
||||
@ -555,7 +534,7 @@ OVER:
|
||||
push de
|
||||
push hl
|
||||
push de
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b c d -- a b c d a b )
|
||||
.db "2OVER"
|
||||
@ -574,65 +553,12 @@ OVER2:
|
||||
push hl ; D
|
||||
push iy ; A
|
||||
push bc ; B
|
||||
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
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A + B
|
||||
.db "+"
|
||||
.fill 6
|
||||
.dw J
|
||||
.dw OVER2
|
||||
.db 0
|
||||
PLUS:
|
||||
.dw nativeWord
|
||||
@ -640,7 +566,7 @@ PLUS:
|
||||
pop de
|
||||
add hl, de
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A - B
|
||||
.db "-"
|
||||
@ -654,7 +580,7 @@ MINUS:
|
||||
or a ; reset carry
|
||||
sbc hl, de
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A * B
|
||||
.db "*"
|
||||
@ -667,7 +593,7 @@ MULT:
|
||||
pop bc
|
||||
call multDEBC
|
||||
push hl
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a b -- c ) A / B
|
||||
.db "/"
|
||||
@ -680,7 +606,7 @@ DIV:
|
||||
pop hl
|
||||
call divide
|
||||
push bc
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( a1 a2 -- b )
|
||||
.db "SCMP"
|
||||
@ -694,7 +620,7 @@ SCMP:
|
||||
call strcmp
|
||||
call flagsToBC
|
||||
push bc
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; ( n1 n2 -- f )
|
||||
.db "CMP"
|
||||
@ -709,7 +635,7 @@ CMP:
|
||||
sbc hl, de
|
||||
call flagsToBC
|
||||
push bc
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; 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
|
||||
@ -721,12 +647,14 @@ CMP:
|
||||
FBR:
|
||||
.dw nativeWord
|
||||
push de
|
||||
ld hl, (IP)
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
ld a, (hl)
|
||||
call addHL
|
||||
ld (IP), hl
|
||||
ld (ix), l
|
||||
ld (ix+1), h
|
||||
pop de
|
||||
jp next
|
||||
jp exit
|
||||
|
||||
; Conditional branch, only branch if TOS is zero
|
||||
.db "(fbr?)"
|
||||
@ -740,11 +668,25 @@ FBRC:
|
||||
or l
|
||||
jr z, FBR+2
|
||||
; skip next byte in RS
|
||||
ld hl, (IP)
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
inc hl
|
||||
ld (IP), hl
|
||||
jp next
|
||||
ld (ix), l
|
||||
ld (ix+1), h
|
||||
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:
|
||||
.dw FBRC
|
||||
|
||||
.dw RECURSE
|
||||
|
||||
@ -36,9 +36,7 @@ directly, but as part of another word.
|
||||
; R:I -- Exit a colon definition
|
||||
, n -- Write n in HERE and advance it.
|
||||
' x -- a Push addr of word x to a.
|
||||
['] x -- *I* Like "'", but spits the addr as a number
|
||||
literal.
|
||||
( -- *I* Comment. Ignore rest of line until ")" is read.
|
||||
['] x -- *I* Like "'", but spits the addr as a number literal.
|
||||
ALLOT n -- Move HERE by n bytes
|
||||
C, b -- Write byte b in HERE and advance it.
|
||||
CREATE x -- Create cell named x. Doesn't allocate a PF.
|
||||
@ -62,7 +60,7 @@ QUIT R:drop -- Return to interpreter promp immediately
|
||||
RECURSE R:I -- R:I-2 Run the current word again.
|
||||
THEN I:a -- *I* Set branching cell at a.
|
||||
|
||||
*** Parameter Stack ***
|
||||
*** Stack ***
|
||||
DUP a -- a a
|
||||
OVER a b -- a b a
|
||||
SWAP a b -- b a
|
||||
@ -70,13 +68,6 @@ SWAP a b -- b a
|
||||
2OVER a b c d -- a b 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 ***
|
||||
@ a -- n Set n to value at address a
|
||||
! n a -- Store n in address a
|
||||
@ -84,7 +75,7 @@ J -- n Copy RS third item to PS
|
||||
+! 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 -- a Set a to wordref of last added entry.
|
||||
CURRENT -- n Set n to wordref of last added entry.
|
||||
HERE -- a Push HERE's address
|
||||
H -- a HERE @
|
||||
|
||||
@ -105,8 +96,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
|
||||
|
||||
*** Strings ***
|
||||
LIT@ x -- a Read following LIT and push its addr to a
|
||||
SCMP a1 a2 -- n Compare strings a1 and a2. See CMP
|
||||
LIT@ x -- a Read folloing LIT and push its addr to a
|
||||
S= a1 a2 -- n Compare strings a1 and a2. See CMP
|
||||
|
||||
*** I/O ***
|
||||
. n -- Print n in its decimal form
|
||||
@ -114,5 +105,4 @@ EMIT c -- Spit char c to stdout
|
||||
KEY -- c Get char c from stdin
|
||||
PC! c a -- Spit c to port a
|
||||
PC@ a -- c Fetch c from port a
|
||||
WORD -- a Read one word from stdin and push its addr
|
||||
|
||||
|
||||
@ -17,15 +17,9 @@
|
||||
|
||||
; *** Variables ***
|
||||
.equ INITIAL_SP FORTH_RAMSTART
|
||||
; wordref of the last entry of the dict.
|
||||
.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
|
||||
; Used to hold HERE while we temporarily point it to COMPBUF
|
||||
.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.
|
||||
.equ INPUTPOS @+2
|
||||
; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
|
||||
@ -65,23 +59,6 @@
|
||||
;
|
||||
; During IMMEDIATE mode, (HERE) is temporarily set to COMPBUF, and when we're
|
||||
; 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 ***
|
||||
forthMain:
|
||||
@ -105,14 +82,10 @@ forthMain:
|
||||
forthRdLine:
|
||||
ld hl, msgOk
|
||||
call printstr
|
||||
forthRdLineNoOk:
|
||||
call printcrlf
|
||||
call stdioReadLine
|
||||
ld ix, RS_ADDR-2 ; -2 because we inc-before-push
|
||||
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.
|
||||
; Let's save current (HERE) and temporarily set it to COMPBUF.
|
||||
ld hl, (HERE)
|
||||
@ -155,17 +128,11 @@ forthInterpret:
|
||||
ld (HERE), de
|
||||
jr forthInterpret
|
||||
.immed:
|
||||
; For this IMMEDIATE word to be compatible with regular execution model,
|
||||
; it needs to be compiled as an atom list. We need a temporary space for
|
||||
; this, let's use (OLDHERE) while it isn't used.
|
||||
ex de, hl ; atom to write in DE
|
||||
ld hl, (OLDHERE)
|
||||
call DEinHL
|
||||
; Now, let's write the .retRef
|
||||
ld de, .retRef
|
||||
call DEinHL
|
||||
ld iy, (OLDHERE)
|
||||
jr .execIY
|
||||
push hl ; --> lvl 1
|
||||
ld hl, .retRef
|
||||
call pushRS
|
||||
pop iy ; <-- lvl 1
|
||||
jp executeCodeLink
|
||||
.execute:
|
||||
ld de, QUIT
|
||||
call .writeDE
|
||||
@ -173,25 +140,23 @@ forthInterpret:
|
||||
ld hl, (OLDHERE)
|
||||
ld (HERE), hl
|
||||
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
|
||||
.writeDE:
|
||||
push hl
|
||||
ld hl, (HERE)
|
||||
call DEinHL
|
||||
ld (hl), e
|
||||
inc hl
|
||||
ld (hl), d
|
||||
inc hl
|
||||
ld (HERE), hl
|
||||
pop hl
|
||||
ret
|
||||
|
||||
.retRef:
|
||||
.dw forthInterpret
|
||||
.dw $+2
|
||||
.dw $+2
|
||||
call popRS
|
||||
jr forthInterpret
|
||||
|
||||
msgOk:
|
||||
.db " ok", 0
|
||||
|
||||
@ -36,15 +36,8 @@ skipRS:
|
||||
pop hl
|
||||
ret
|
||||
|
||||
; Verifies that SP and RS are within bounds. If it's not, call ABORT
|
||||
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
|
||||
; Verifies that SP is within bounds. If it's not, call ABORT
|
||||
chkPS:
|
||||
ld hl, (INITIAL_SP)
|
||||
; We have the return address for this very call on the stack. Let's
|
||||
; compensate
|
||||
@ -52,7 +45,6 @@ chkPSRS:
|
||||
or a ; clear carry
|
||||
sbc hl, sp
|
||||
ret nc ; (INITIAL_SP) >= SP? good
|
||||
.underflow:
|
||||
; underflow
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
|
||||
@ -80,6 +80,13 @@ HLPointsBR:
|
||||
pop de
|
||||
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,
|
||||
; 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.
|
||||
@ -195,31 +202,20 @@ readLIT:
|
||||
.db "word expected", 0
|
||||
|
||||
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 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)
|
||||
ld hl, (RS_ADDR)
|
||||
call readLIT
|
||||
ld (RS_ADDR+2), de
|
||||
ld (RS_ADDR), de
|
||||
pop de
|
||||
ret
|
||||
|
||||
readLITTOS:
|
||||
push de
|
||||
ld hl, (IP)
|
||||
ld l, (ix)
|
||||
ld h, (ix+1)
|
||||
call readLIT
|
||||
ld (IP), de
|
||||
ld (ix), e
|
||||
ld (ix+1), d
|
||||
pop de
|
||||
ret
|
||||
|
||||
@ -288,6 +284,7 @@ entryhead:
|
||||
inc hl
|
||||
ld (CURRENT), hl
|
||||
ld (HERE), hl
|
||||
xor a ; set Z
|
||||
ret
|
||||
|
||||
; Sets Z if wordref at HL is of the IMMEDIATE type
|
||||
|
||||
1
emul/.gitignore
vendored
1
emul/.gitignore
vendored
@ -1,6 +1,5 @@
|
||||
/shell/shell
|
||||
/forth/stage1
|
||||
/forth/stage1dbg
|
||||
/forth/forth
|
||||
/zasm/zasm
|
||||
/zasm/avra
|
||||
|
||||
@ -33,9 +33,6 @@ forth/forth0-bin.h: forth/forth0.bin
|
||||
forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h
|
||||
$(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/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null
|
||||
|
||||
|
||||
@ -20,11 +20,6 @@ directly follow executable's last byte so that we don't waste spce and also
|
||||
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
|
||||
#define RAMSTART 0x900
|
||||
#define STDIO_PORT 0x00
|
||||
@ -49,17 +44,11 @@ static uint8_t iord_stdio()
|
||||
static void iowr_stdio(uint8_t val)
|
||||
{
|
||||
// we don't output stdout in stage0
|
||||
#ifdef DEBUG
|
||||
// ... unless we're in DEBUG mode!
|
||||
putchar(val);
|
||||
#endif
|
||||
}
|
||||
|
||||
int main(int argc, char *argv[])
|
||||
{
|
||||
#ifdef DEBUG
|
||||
fp = stdin;
|
||||
#else
|
||||
bool tty = false;
|
||||
if (argc == 2) {
|
||||
fp = fopen(argv[1], "r");
|
||||
if (fp == NULL) {
|
||||
@ -70,7 +59,6 @@ int main(int argc, char *argv[])
|
||||
fprintf(stderr, "Usage: ./stage0 filename\n");
|
||||
return 1;
|
||||
}
|
||||
#endif
|
||||
Machine *m = emul_init();
|
||||
m->ramstart = RAMSTART;
|
||||
m->iord[STDIO_PORT] = iord_stdio;
|
||||
@ -86,7 +74,6 @@ int main(int argc, char *argv[])
|
||||
|
||||
fclose(fp);
|
||||
|
||||
#ifndef DEBUG
|
||||
// We're done, now let's spit dict data
|
||||
// let's start with LATEST spitting.
|
||||
putchar(m->mem[CURRENT]);
|
||||
@ -95,7 +82,6 @@ int main(int argc, char *argv[])
|
||||
for (int i=sizeof(KERNEL); i<here; i++) {
|
||||
putchar(m->mem[i]);
|
||||
}
|
||||
#endif
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user