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

Compare commits

..

No commits in common. "839021e0f8e3523b0916c8a57215f3c651ecd793" and "cb3e6469b825d64dbb5f82363ef12565808b305c" have entirely different histories.

6 changed files with 140 additions and 187 deletions

View File

@ -103,7 +103,7 @@ updatebootstrap: $(ZASMBIN)
# words and they write to HERE at initialization. # words and they write to HERE at initialization.
.PHONY: fbootstrap .PHONY: fbootstrap
fbootstrap: forth/stage2 fbootstrap: forth/stage2
cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/icore.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null cat ../forth/dummy.fs ../forth/z80c.fs forth/emul.fs ../forth/dummy.fs | ./forth/stage2 | tee forth/z80c.bin > /dev/null
.PHONY: clean .PHONY: clean
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 -- Write number n as a literal.
[LITN] n -- *I* Immediate version of LITN. [LITN] n -- *I* Immediate version of LITN.
ROUTINE x -- a Push the addr of the specified core routine ROUTINE x -- a Push the addr of the specified core routine
C=cellWord J=JUMPTBL V=nativeWord N=next S=LIT C=cellWord L=compiledWord V=nativeWord N=next S=LIT
M=NUMBER Y=sysvarWord D=doesWord M=NUMBER Y=sysvarWord D=doesWord
VARIABLE c -- Creates cell x with 2 bytes allocation. VARIABLE c -- Creates cell x with 2 bytes allocation.

View File

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

View File

@ -1,85 +0,0 @@
( 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,15 +113,6 @@ CODE XOR
HL PUSHqq, HL PUSHqq,
;CODE ;CODE
CODE -
DE POPqq,
HL POPqq,
chkPS,
A ORr,
DE SBCHLss,
HL PUSHqq,
;CODE
CODE * CODE *
DE POPqq, DE POPqq,
BC POPqq, BC POPqq,
@ -216,16 +207,3 @@ CODE J
H 3 IX- LDrIXY, H 3 IX- LDrIXY,
HL PUSHqq, HL PUSHqq,
;CODE ;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