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

Compare commits

...

6 Commits

Author SHA1 Message Date
Virgil Dupras
839021e0f8 forth: Forth-ify "(print)" 2020-03-27 12:39:59 -04:00
Virgil Dupras
edcd80e3a6 forth: Forth-ify "(parse)" 2020-03-27 11:49:50 -04:00
Virgil Dupras
941224be94 forth: Forth-ify "-" 2020-03-27 11:36:58 -04:00
Virgil Dupras
005dd98fc2 forth: Forth-ify "R>" and ">R" 2020-03-27 11:27:40 -04:00
Virgil Dupras
1e7e696e4a forth: Forth-ify ";"!!!
Ain't that not self-bootstrapping enough to your taste? Whoa, I'm
getting dizzy...
2020-03-27 09:32:03 -04:00
Virgil Dupras
dad0081123 forth: Forth-ify "INTERPRET"!!!
Now we're seriously getting into real boostrapping territory...
2020-03-27 08:23:45 -04:00
6 changed files with 187 additions and 140 deletions

View File

@ -103,7 +103,7 @@ updatebootstrap: $(ZASMBIN)
# words and they write to HERE at initialization.
.PHONY: fbootstrap
fbootstrap: forth/stage2
cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/icore.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
.PHONY: clean
clean:

Binary file not shown.

View File

@ -54,7 +54,7 @@ IMMEDIATE -- Flag the latest defined word as immediate.
LITN n -- Write number n as a literal.
[LITN] n -- *I* Immediate version of LITN.
ROUTINE x -- a Push the addr of the specified core routine
C=cellWord L=compiledWord V=nativeWord N=next S=LIT
C=cellWord J=JUMPTBL V=nativeWord N=next S=LIT
M=NUMBER Y=sysvarWord D=doesWord
VARIABLE c -- Creates cell x with 2 bytes allocation.

View File

@ -10,6 +10,14 @@
; self-hosts in a more compact manner. File include is a big part of the
; complexity in zasm. If we can get rid of it, we'll be more compact.
; *** ABI STABILITY ***
;
; This unit needs to have some of its entry points stay at a stable offset.
; These have a comment over them indicating the expected offset. These should
; not move until the Grand Bootstrapping operation has been completed.
;
; When you see random ".fill" here and there, it's to ensure that stability.
; *** Defines ***
; GETC: address of a GetC routine
; PUTC: address of a PutC routine
@ -58,6 +66,8 @@
.equ CINPTR @+2
; Pointer to (emit) word
.equ EMITPTR @+2
; Pointer to (print) word
.equ PRINTPTR @+2
.equ WORDBUF @+2
; Sys Vars are variables with their value living in the system RAM segment. We
; need this mechanisms for core Forth source needing variables. Because core
@ -105,11 +115,17 @@
; change bootstrap binaries have to be adjusted because they rely on them.
; We're at 0 here
jp forthMain
.fill 0x17-$
.fill 0x11-$
JUMPTBL:
jp pushRS
jp popRS
jp nativeWord
jp next
jp chkPS
NUMBER:
.dw numberWord
LIT:
.dw litWord
; *** Code ***
forthMain:
@ -137,6 +153,10 @@ forthMain:
ld hl, .emitName
call find
ld (EMITPTR), de
; Set up PRINTPTR
ld hl, .printName
call find
ld (PRINTPTR), de
; Set up CINPTR
; do we have a (c<) impl?
ld hl, .cinName
@ -160,6 +180,8 @@ forthMain:
.db "(c<)", 0
.emitName:
.db "(emit)", 0
.printName:
.db "(print)", 0
.keyName:
.db "KEY", 0
@ -175,31 +197,13 @@ BEGIN:
INTERPRET:
.dw compiledWord
; BBR mark
.dw WORD
.dw LIT
.db "INTERPRET", 0
.dw FIND_
.dw CSKIP
.dw FBR
.db 22
; It's a word, execute it
; For now, we only have one flag, let's take advantage of
; this to keep code simple.
.dw NUMBER ; Bit 0 on
.dw 1
.dw FLAGS_
.dw STORE
.dw DROP
.dw EXECUTE
.dw NUMBER ; Bit 0 off
.dw 0
.dw FLAGS_
.dw STORE
.dw BBR
.db 29
; FBR mark, try number
.dw PARSEI
.dw BBR
.db 34
; infinite loop
.fill 13
; *** Collapse OS lib copy ***
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
@ -625,9 +629,6 @@ numberWord:
push de
jp next
NUMBER:
.dw numberWord
; Similarly to numberWord, this is not a real word, but a string literal.
; Instead of being followed by a 2 bytes number, it's followed by a
; null-terminated string. When called, puts the string's address on PS
@ -639,9 +640,6 @@ litWord:
ld (IP), hl
jp next
LIT:
.dw litWord
; Pop previous IP from Return stack and execute it.
; ( R:I -- )
.db "EXIT"
@ -691,8 +689,11 @@ abortUnderflow:
.word:
.dw compiledWord
.dw LIT
.db "stack underflow", 0
.dw PRINT
.db "stack underfl", 0
.dw NUMBER
.dw PRINTPTR
.dw FETCH
.dw EXECUTE
.dw ABORT
.db "BYE"
@ -702,6 +703,9 @@ BYE:
.dw nativeWord
halt
; STABLE ABI
; Offset: 02aa
.out $
; ( c -- )
.db "EMIT"
.dw $-BYE
@ -715,43 +719,10 @@ EMIT:
.dw EXIT
.db "(print)"
.dw $-EMIT
.db 7
PRINT:
.dw compiledWord ; a
; BBR mark
.dw DUP ; a a
.dw .getc ; a c
.dw DUP ; a c f
.dw CSKIP ; a c
; zero, end of string
.dw FBR
.db 12
.dw EMIT ; a
.dw NUMBER ; a 1
.dw 1
.dw PLUS ; a+1
.dw BBR
.db 21
; FBR mark
.dw DROP
.dw DROP
.dw EXIT
; Yes, very much like C@, but it has already been Forth-ified...
.getc:
.dw nativeWord
pop hl
call chkPS
ld l, (hl)
ld h, 0
push hl
jp next
.fill 49
.db "C,"
.dw $-PRINT
.dw $-EMIT
.db 2
CWR:
.dw nativeWord
@ -794,13 +765,13 @@ ROUTINE:
ld de, cellWord
cp 'C'
jr z, .end
ld de, compiledWord
cp 'L'
jr z, .end
ld de, JUMPTBL
cp 'J'
jr z, .end
ld de, JUMPTBL+6
cp 'V'
jr z, .end
ld de, JUMPTBL+3
ld de, JUMPTBL+9
cp 'N'
jr z, .end
ld de, sysvarWord
@ -815,7 +786,7 @@ ROUTINE:
ld de, NUMBER
cp 'M'
jr z, .end
ld de, JUMPTBL+6
ld de, JUMPTBL+12
cp 'P'
jr nz, .notgood
; continue to end on match
@ -835,6 +806,9 @@ ROUTINE:
.db "EXECUTE"
.dw $-ROUTINE
.db 7
; STABLE ABI
; Offset: 0388
.out $
EXECUTE:
.dw nativeWord
pop iy ; is a wordref
@ -848,22 +822,9 @@ EXECUTE:
jp (hl) ; go!
.db ";"
.dw $-EXECUTE
.db 0x81 ; IMMEDIATE
ENDDEF:
.dw compiledWord
.dw NUMBER
.dw EXIT
.dw WR
.dw R2P ; exit COMPILE
.dw DROP
.dw R2P ; exit DEFINE
.dw DROP
.dw EXIT
.fill 22
.db ":"
.dw $-ENDDEF
.dw $-EXECUTE
.db 0x81 ; IMMEDIATE
DEFINE:
.dw compiledWord
@ -983,6 +944,9 @@ SCPY:
.db "(find)"
.dw $-SCPY
.db 6
; STABLE ABI
; Offset: 047c
.out $
FIND_:
.dw nativeWord
pop hl
@ -1070,6 +1034,9 @@ TOWORD:
.db "WORD"
.dw $-TOWORD
.db 4
; STABLE ABI
; Offset: 04f7
.out $
WORD:
.dw compiledWord
.dw NUMBER ; ( a )
@ -1137,23 +1104,7 @@ PARSED:
jp next
.db "(parse)"
.dw $-PARSED
.db 7
PARSE:
.dw compiledWord
.dw PARSED
.dw CSKIP
.dw .error
; success, stack is already good, we can exit
.dw EXIT
.error:
.dw compiledWord
.dw LIT
.db "unknown word", 0
.dw PRINT
.dw ABORT
.fill 41
; Indirect parse caller. Reads PARSEPTR and calls
@ -1168,7 +1119,7 @@ PARSEI:
; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
.db "(entry)"
.dw $-PARSE
.dw $-PARSED
.db 7
ENTRYHEAD:
.dw compiledWord
@ -1202,6 +1153,9 @@ ENTRYHEAD:
jp next
; STABLE ABI (every sysvars)
; Offset: 05ca
.out $
.db "HERE"
.dw $-ENTRYHEAD
.db 4
@ -1241,6 +1195,9 @@ SYSVNXT_:
.db "!"
.dw $-SYSVNXT_
.db 1
; STABLE ABI
; Offset: 0610
.out $
STORE:
.dw nativeWord
pop iy
@ -1266,6 +1223,7 @@ FETCH:
.db "DROP"
.dw $-FETCH
.db 4
; STABLE ABI
DROP:
.dw nativeWord
pop hl
@ -1309,28 +1267,12 @@ OVER:
push de
jp next
.db ">R"
.dw $-OVER
.db 2
P2R:
.dw nativeWord
pop hl
call chkPS
call pushRS
jp next
.db "R>"
.dw $-P2R
.db 2
R2P:
.dw nativeWord
call popRS
push hl
jp next
.fill 31
; ( a b -- c ) A + B
.db "+"
.dw $-R2P
.dw $-OVER
.db 1
PLUS:
.dw nativeWord
@ -1341,23 +1283,11 @@ PLUS:
push hl
jp next
; ( a b -- c ) A - B
.db "-"
.dw $-PLUS
.db 1
MINUS:
.dw nativeWord
pop de ; B
pop hl ; A
call chkPS
or a ; reset carry
sbc hl, de
push hl
jp next
.fill 18
; ( a1 a2 -- b )
.db "SCMP"
.dw $-MINUS
.dw $-PLUS
.db 4
SCMP:
.dw nativeWord
@ -1390,6 +1320,9 @@ CMP:
.db "SKIP?"
.dw $-CMP
.db 5
; STABLE ABI
; Offset: 06ee
.out $
CSKIP:
.dw nativeWord
pop hl
@ -1447,6 +1380,9 @@ CSKIP:
.db "(fbr)"
.dw $-CSKIP
.db 5
; STABLE ABI
; Offset: 073e
.out $
FBR:
.dw nativeWord
push de
@ -1460,6 +1396,9 @@ FBR:
.db "(bbr)"
.dw $-FBR
.db 5
; STABLE ABI
; Offset: 0757
.out $
BBR:
.dw nativeWord
ld hl, (IP)
@ -1473,5 +1412,6 @@ BBR:
; To allow dict binaries to "hook themselves up", we always end such binary
; with a dummy, *empty* entry. Therefore, we can have a predictable place for
; getting a prev label.
.db "_bend"
.dw $-BBR
.db 0
.db 5

85
forth/icore.fs Normal file
View File

@ -0,0 +1,85 @@
( Inner core. This unit represents core definitions that
happen right after native definitions. Before core.fs.
Unlike core.fs and its followers, this unit isn't self-
sustained. Like native defs it uses the machinery of a
full Forth interpreter, notably for flow structures.
Because of that, it has to obey specific rules:
1. It cannot compile a word from higher layers. Using
immediates is fine though.
2. If it references a word from this unit or from native
definitions, these need to be properly offsetted
because their offset at compile time are not the same
as their runtime offsets.
3. Anything they refer to in the boot binary has to be
properly stabilized.
4. Make sure that the words you compile are not overridden
by the full interpreter.
)
( When referencing words from native defs or this very unit,
use this compiling word, which subtract the proper offset
from the compiled word. That proper offset is:
1. Take ROT-header addr, the first native def.
2. Subtract _bend, boot's last word.
3. That will give us the offset to subtract to get the addr
of our word at runtime.
This means, of course, that any word compiling a _c word
can't be executed immediately.
)
: _c
['] ROT
6 - ( header )
['] _bend
- ( our offset )
' ( get word )
-^ ( apply offset )
, ( write! )
; IMMEDIATE
: INTERPRET
BEGIN
WORD
(find)
IF
1 FLAGS !
EXECUTE
0 FLAGS !
ELSE
(parse*) @ EXECUTE
THEN
AGAIN
;
( This is only the "early parser" in earlier stages. No need
for an abort message )
: (parse)
(parsed) SKIP? ABORT
;
( a -- )
: (print)
BEGIN
DUP ( a a )
_c C@ ( a c )
( exit if null )
DUP NOT IF DROP DROP EXIT THEN
EMIT ( a )
1 + ( a+1 )
AGAIN
;
( ; has to be defined last because it can't be executed now )
: X ( can't have its real name now )
['] EXIT ,
_c R> DROP ( exit COMPILE )
_c R> DROP ( exit : )
; IMMEDIATE
( Give ";" its real name )
';' CURRENT @ 4 - C!

View File

@ -113,6 +113,15 @@ CODE XOR
HL PUSHqq,
;CODE
CODE -
DE POPqq,
HL POPqq,
chkPS,
A ORr,
DE SBCHLss,
HL PUSHqq,
;CODE
CODE *
DE POPqq,
BC POPqq,
@ -207,3 +216,16 @@ CODE J
H 3 IX- LDrIXY,
HL PUSHqq,
;CODE
CODE >R
HL POPqq,
chkPS,
( JUMPTBL+0 == pushRS )
ROUTINE J CALLnn,
;CODE
CODE R>
( JUMPTBL+3 == popRS )
ROUTINE J 3 + CALLnn,
HL PUSHqq,
;CODE