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

Compare commits

..

5 Commits

Author SHA1 Message Date
Virgil Dupras
ffe61a12f8 forth: make prev word field relative
This should help with upcoming challenges in bootstrapping z80 code
compiled through Forth.
2020-03-22 17:41:59 -04:00
Virgil Dupras
00de336976 forth: add "CODE"!!! 2020-03-22 12:08:50 -04:00
Virgil Dupras
46833f3819 forth: Forth-ify "LIT", "LITS", "LIT<" 2020-03-22 11:56:40 -04:00
Virgil Dupras
54fd5fbb2b forth: Forth-ify "CREATE" 2020-03-22 11:49:09 -04:00
Virgil Dupras
1e886f5f34 forth: add word "ROUTINE" 2020-03-22 11:25:39 -04:00
9 changed files with 184 additions and 132 deletions

View File

@ -7,7 +7,7 @@ AVRABIN = zasm/avra
SHELLAPPS = zasm ed
SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
# Those Forth source files are in a particular order
FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs high.fs z80a.fs
FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs high.fs z80a.fs dummy.fs
FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%}
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
OBJS = emul.o libz80/libz80.o

View File

@ -34,6 +34,6 @@ emulPutC:
out (STDIO_PORT), a
ret
.dw 0 ; placeholder used in glue1.
CODE_END:
.out LATEST
.out $ ; should be the same as in glue1

View File

@ -1,6 +1,6 @@
; Warning: The offsets of native dict entries must be exactly the same between
; glue0.asm and glue1.asm
.equ LATEST CODE_END ; override
.equ LATEST RAMSTART ; override
.equ STDIO_PORT 0x00
jp init
@ -26,9 +26,6 @@ emulPutC:
out (STDIO_PORT), a
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:
.out $ ; should be the same as in glue0
.bin "core.bin"
RAMSTART:

View File

@ -71,9 +71,6 @@ int main(int argc, char *argv[])
#ifndef DEBUG
// 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]);

View File

@ -1,5 +1,9 @@
: H HERE @ ;
: -^ SWAP - ;
: [LITN] LITN ; IMMEDIATE
: LIT ROUTINE S [LITN] , ;
: LITS LIT SCPY ;
: LIT< WORD LITS ; IMMEDIATE
: COMPILE ' LITN ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: BEGIN H ; IMMEDIATE
@ -37,6 +41,11 @@
H 1 - ( push a. -1 for allot offset )
; IMMEDIATE
: CREATE
WORD (entry) ( empty header with name )
ROUTINE C [LITN] ( push cellWord addr )
, ( write it )
;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE H ! DOES> @ ;
: = CMP NOT ;

View File

@ -52,6 +52,10 @@ DOES> -- See description at top of file
IMMED? a -- f Checks whether wordref at a is immediate.
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
N=NUMBER Y=sysvarWord D=doesWord
VARIABLE c -- Creates cell x with 2 bytes allocation.
Compilation vs meta-compilation. When you compile a word with "[COMPILE] foo",

4
forth/dummy.fs Normal file
View File

@ -0,0 +1,4 @@
( When building a compiled dict, always include this unit at
the end of it so that Forth knows how to hook LATEST into
it )
WORD _______ (entry)

View File

@ -119,12 +119,10 @@ forthMain:
push af \ push af \ push af
ld (INITIAL_SP), sp
ld ix, RS_ADDR
; 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.
; LATEST is a label to the latest entry of the dict. This can be
; overridden if a binary dict has been grafted to the end of this
; binary
ld hl, LATEST
call intoHL
ld (CURRENT), hl
ld hl, HERE_INITIAL
ld (HERE), hl
@ -416,9 +414,12 @@ find:
call strncmp
pop de ; <-- lvl 1, return to wordref
jr z, .end ; found
push hl ; .prev destroys HL
call .prev
pop hl
jr nz, .inner
; Z set? end of dict unset Z
xor a
inc a
.end:
pop bc
@ -429,15 +430,21 @@ find:
; Z is set if DE point to 0 (no entry). NZ if not.
.prev:
dec de \ dec de \ dec de ; prev field
push de ; --> lvl 1
ex de, hl
call intoHL
ex de, hl ; de preserved by intoHL, so no push/pop needed
; DE points to prev. Is it zero?
xor a
or d
ex de, hl ; DE contains prev offset
pop hl ; <-- lvl 1
; HL is prev field's addr
; Is offset zero?
ld a, d
or e
; Z will be set if DE is zero
ret
ret z ; no prev entry
; get absolute addr from offset
; carry cleared from "or e"
sbc hl, de
ex de, hl ; result in DE
ret ; NZ set from SBC
; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
flagsToBC:
@ -519,11 +526,14 @@ chkPS:
; It's important that this part is at the end of the resulting binary.
; A dictionary entry has this structure:
; - 7b name (zero-padded)
; - 2b prev pointer
; - 2b prev offset
; - 1b flags (bit 0: IMMEDIATE)
; - 2b code pointer
; - Parameter field (PF)
;
; The prev offset is the number of bytes between the prev field and the
; previous word's code pointer.
;
; 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".
@ -642,7 +652,7 @@ EXIT:
; ( R:I -- )
.db "QUIT"
.fill 3
.dw EXIT
.dw $-EXIT
.db 0
QUIT:
.dw compiledWord
@ -659,7 +669,7 @@ QUIT:
.db "ABORT"
.fill 2
.dw QUIT
.dw $-QUIT
.db 0
ABORT:
.dw compiledWord
@ -685,7 +695,7 @@ abortUnderflow:
.db "BYE"
.fill 4
.dw ABORT
.dw $-ABORT
.db 0
BYE:
.dw nativeWord
@ -700,7 +710,7 @@ BYE:
; ( c -- )
.db "EMIT"
.fill 3
.dw BYE
.dw $-BYE
.db 0
EMIT:
.dw nativeWord
@ -711,7 +721,7 @@ EMIT:
jp next
.db "(print)"
.dw EMIT
.dw $-EMIT
.db 0
PRINT:
.dw nativeWord
@ -728,7 +738,7 @@ PRINT:
; ( c port -- )
.db "PC!"
.fill 4
.dw PRINT
.dw $-PRINT
.db 0
PSTORE:
.dw nativeWord
@ -741,7 +751,7 @@ PSTORE:
; ( port -- c )
.db "PC@"
.fill 4
.dw PSTORE
.dw $-PSTORE
.db 0
PFETCH:
.dw nativeWord
@ -754,7 +764,7 @@ PFETCH:
.db "C,"
.fill 5
.dw PFETCH
.dw $-PFETCH
.db 0
CWR:
.dw nativeWord
@ -769,7 +779,7 @@ CWR:
.db ","
.fill 6
.dw CWR
.dw $-CWR
.db 0
WR:
.dw nativeWord
@ -781,9 +791,63 @@ WR:
jp next
.db "ROUTINE"
.dw $-WR
.db 1 ; IMMEDIATE
ROUTINE:
.dw compiledWord
.dw WORD
.dw .private
.dw EXIT
.private:
.dw nativeWord
pop hl
call chkPS
ld a, (hl)
ld de, cellWord
cp 'C'
jr z, .end
ld de, compiledWord
cp 'L'
jr z, .end
ld de, nativeWord
cp 'V'
jr z, .end
ld de, next
cp 'N'
jr z, .end
ld de, sysvarWord
cp 'Y'
jr z, .end
ld de, doesWord
cp 'D'
jr z, .end
ld de, LIT
cp 'S'
jr z, .end
ld de, NUMBER
cp 'N'
jr z, .end
ld de, chkPS
cp 'P'
jr nz, .notgood
; continue to end on match
.end:
; is our slen 1?
inc hl
ld a, (hl)
or a
jr z, .good
.notgood:
ld de, 0
.good:
push de
jp next
; ( addr -- )
.db "EXECUTE"
.dw WR
.dw $-ROUTINE
.db 0
EXECUTE:
.dw nativeWord
@ -800,7 +864,7 @@ EXECUTE:
.db ";"
.fill 6
.dw EXECUTE
.dw $-EXECUTE
.db 1 ; IMMEDIATE
ENDDEF:
.dw compiledWord
@ -815,7 +879,7 @@ ENDDEF:
.db ":"
.fill 6
.dw ENDDEF
.dw $-ENDDEF
.db 1 ; IMMEDIATE
DEFINE:
.dw compiledWord
@ -860,7 +924,7 @@ DEFINE:
.db "DOES>"
.fill 2
.dw DEFINE
.dw $-DEFINE
.db 0
DOES:
.dw nativeWord
@ -881,7 +945,7 @@ DOES:
.db "IMMEDIA"
.dw DOES
.dw $-DOES
.db 0
IMMEDIATE:
.dw nativeWord
@ -893,7 +957,7 @@ IMMEDIATE:
.db "IMMED?"
.fill 1
.dw IMMEDIATE
.dw $-IMMEDIATE
.db 0
ISIMMED:
.dw nativeWord
@ -911,7 +975,7 @@ ISIMMED:
; ( n -- )
.db "LITN"
.fill 3
.dw ISIMMED
.dw $-ISIMMED
.db 0
LITN:
.dw nativeWord
@ -926,7 +990,7 @@ LITN:
.db "SCPY"
.fill 3
.dw LITN
.dw $-LITN
.db 0
SCPY:
.dw nativeWord
@ -937,41 +1001,9 @@ SCPY:
jp next
.db "LIT"
.fill 4
.dw SCPY
.db 0
LIT_:
.dw compiledWord
.dw NUMBER
.dw LIT
.dw WR
.dw EXIT
.db "LITS"
.fill 3
.dw LIT_
.db 0
LITS:
.dw compiledWord
.dw LIT_
.dw SCPY
.dw EXIT
.db "LIT<"
.fill 3
.dw LITS
.db 1 ; IMMEDIATE
LITRD:
.dw compiledWord
.dw WORD
.dw LITS
.dw EXIT
.db "(find)"
.fill 1
.dw LITRD
.dw $-SCPY
.db 0
FIND_:
.dw nativeWord
@ -991,7 +1023,7 @@ FIND_:
.db "'"
.fill 6
.dw FIND_
.dw $-FIND_
.db 0
FIND:
.dw compiledWord
@ -1003,7 +1035,7 @@ FIND:
.db "[']"
.fill 4
.dw FIND
.dw $-FIND
.db 0b01 ; IMMEDIATE
FINDI:
.dw compiledWord
@ -1025,7 +1057,7 @@ FINDERR:
; ( -- c )
.db "KEY"
.fill 4
.dw FINDI
.dw $-FINDI
.db 0
KEY:
.dw nativeWord
@ -1054,7 +1086,7 @@ CIN:
; 32 CMP 1 -
.db "WS?"
.fill 4
.dw KEY
.dw $-KEY
.db 0
ISWS:
.dw compiledWord
@ -1068,7 +1100,7 @@ ISWS:
.db "NOT"
.fill 4
.dw ISWS
.dw $-ISWS
.db 0
NOT:
.dw nativeWord
@ -1088,7 +1120,7 @@ NOT:
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
.db "TOWORD"
.fill 1
.dw NOT
.dw $-NOT
.db 0
TOWORD:
.dw compiledWord
@ -1105,7 +1137,7 @@ TOWORD:
; HL point to WORDBUF.
.db "WORD"
.fill 3
.dw TOWORD
.dw $-TOWORD
.db 0
WORD:
.dw compiledWord
@ -1152,7 +1184,7 @@ WORD:
.db "(parsed"
.dw WORD
.dw $-WORD
.db 0
PARSED:
.dw nativeWord
@ -1173,7 +1205,7 @@ PARSED:
.db "(parse)"
.dw PARSED
.dw $-PARSED
.db 0
PARSE:
.dw compiledWord
@ -1202,6 +1234,9 @@ PARSEI:
; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
.db "(entry)"
.dw $-PARSE
.db 0
ENTRYHEAD:
.dw nativeWord
pop hl
@ -1211,6 +1246,11 @@ ENTRYHEAD:
ld de, (CURRENT)
ld a, NAMELEN
call addHL
push hl ; --> lvl 1
or a ; clear carry
sbc hl, de
ex de, hl
pop hl ; <-- lvl 1
call DEinHL
; Set word flags: not IMMED, so it's 0
xor a
@ -1221,19 +1261,6 @@ ENTRYHEAD:
jp next
.db "CREATE"
.fill 1
.dw PARSE
.db 0
CREATE:
.dw compiledWord
.dw WORD
.dw ENTRYHEAD
.dw NUMBER
.dw cellWord
.dw WR
.dw EXIT
; WARNING: there are no limit checks. We must be cautious, in core code, not
; to create more than SYSV_BUFSIZE/2 sys vars.
; Also: SYSV shouldn't be used during runtime: SYSVNXT won't point at the
@ -1241,7 +1268,7 @@ CREATE:
; this word is not documented in dictionary.txt
.db "(sysv)"
.fill 1
.dw CREATE
.dw $-ENTRYHEAD
.db 0
SYSV:
.dw compiledWord
@ -1269,21 +1296,21 @@ SYSV:
.db "HERE"
.fill 3
.dw SYSV
.dw $-SYSV
.db 0
HERE_: ; Caution: conflicts with actual variable name
.dw sysvarWord
.dw HERE
.db "CURRENT"
.dw HERE_
.dw $-HERE_
.db 0
CURRENT_:
.dw sysvarWord
.dw CURRENT
.db "(parse*"
.dw CURRENT_
.dw $-CURRENT_
.db 0
PARSEPTR_:
.dw sysvarWord
@ -1291,7 +1318,7 @@ PARSEPTR_:
.db "FLAGS"
.fill 2
.dw PARSEPTR_
.dw $-PARSEPTR_
.db 0
FLAGS_:
.dw sysvarWord
@ -1300,7 +1327,7 @@ FLAGS_:
; ( n a -- )
.db "!"
.fill 6
.dw FLAGS_
.dw $-FLAGS_
.db 0
STORE:
.dw nativeWord
@ -1314,7 +1341,7 @@ STORE:
; ( n a -- )
.db "C!"
.fill 5
.dw STORE
.dw $-STORE
.db 0
CSTORE:
.dw nativeWord
@ -1327,7 +1354,7 @@ CSTORE:
; ( a -- n )
.db "@"
.fill 6
.dw CSTORE
.dw $-CSTORE
.db 0
FETCH:
.dw nativeWord
@ -1340,7 +1367,7 @@ FETCH:
; ( a -- c )
.db "C@"
.fill 5
.dw FETCH
.dw $-FETCH
.db 0
CFETCH:
.dw nativeWord
@ -1354,7 +1381,7 @@ CFETCH:
; ( a -- )
.db "DROP"
.fill 3
.dw CFETCH
.dw $-CFETCH
.db 0
DROP:
.dw nativeWord
@ -1364,7 +1391,7 @@ DROP:
; ( a b -- b a )
.db "SWAP"
.fill 3
.dw DROP
.dw $-DROP
.db 0
SWAP:
.dw nativeWord
@ -1377,7 +1404,7 @@ SWAP:
; ( a b c d -- c d a b )
.db "2SWAP"
.fill 2
.dw SWAP
.dw $-SWAP
.db 0
SWAP2:
.dw nativeWord
@ -1395,7 +1422,7 @@ SWAP2:
; ( a -- a a )
.db "DUP"
.fill 4
.dw SWAP2
.dw $-SWAP2
.db 0
DUP:
.dw nativeWord
@ -1408,7 +1435,7 @@ DUP:
; ( a b -- a b a b )
.db "2DUP"
.fill 3
.dw DUP
.dw $-DUP
.db 0
DUP2:
.dw nativeWord
@ -1424,7 +1451,7 @@ DUP2:
; ( a b -- a b a )
.db "OVER"
.fill 3
.dw DUP2
.dw $-DUP2
.db 0
OVER:
.dw nativeWord
@ -1439,7 +1466,7 @@ OVER:
; ( a b c d -- a b c d a b )
.db "2OVER"
.fill 2
.dw OVER
.dw $-OVER
.db 0
OVER2:
.dw nativeWord
@ -1459,7 +1486,7 @@ OVER2:
; ( a b c -- b c a)
.db "ROT"
.fill 4
.dw OVER2
.dw $-OVER2
.db 0
ROT:
.dw nativeWord
@ -1474,7 +1501,7 @@ ROT:
.db ">R"
.fill 5
.dw ROT
.dw $-ROT
.db 0
P2R:
.dw nativeWord
@ -1485,7 +1512,7 @@ P2R:
.db "R>"
.fill 5
.dw P2R
.dw $-P2R
.db 0
R2P:
.dw nativeWord
@ -1495,7 +1522,7 @@ R2P:
.db "I"
.fill 6
.dw R2P
.dw $-R2P
.db 0
I:
.dw nativeWord
@ -1506,7 +1533,7 @@ I:
.db "I'"
.fill 5
.dw I
.dw $-I
.db 0
IPRIME:
.dw nativeWord
@ -1517,7 +1544,7 @@ IPRIME:
.db "J"
.fill 6
.dw IPRIME
.dw $-IPRIME
.db 0
J:
.dw nativeWord
@ -1529,7 +1556,7 @@ J:
; ( a b -- c ) A + B
.db "+"
.fill 6
.dw J
.dw $-J
.db 0
PLUS:
.dw nativeWord
@ -1543,7 +1570,7 @@ PLUS:
; ( a b -- c ) A - B
.db "-"
.fill 6
.dw PLUS
.dw $-PLUS
.db 0
MINUS:
.dw nativeWord
@ -1558,7 +1585,7 @@ MINUS:
; ( a b -- c ) A * B
.db "*"
.fill 6
.dw MINUS
.dw $-MINUS
.db 0
MULT:
.dw nativeWord
@ -1585,7 +1612,7 @@ MULT:
.db "/MOD"
.fill 3
.dw MULT
.dw $-MULT
.db 0
DIVMOD:
.dw nativeWord
@ -1600,7 +1627,7 @@ DIVMOD:
.db "AND"
.fill 4
.dw DIVMOD
.dw $-DIVMOD
.db 0
AND:
.dw nativeWord
@ -1618,7 +1645,7 @@ AND:
.db "OR"
.fill 5
.dw AND
.dw $-AND
.db 0
OR:
.dw nativeWord
@ -1636,7 +1663,7 @@ OR:
.db "XOR"
.fill 4
.dw OR
.dw $-OR
.db 0
XOR:
.dw nativeWord
@ -1658,7 +1685,7 @@ XOR:
.db "0"
.fill 6
.dw XOR
.dw $-XOR
.db 0
ZERO:
.dw nativeWord
@ -1668,7 +1695,7 @@ ZERO:
.db "1"
.fill 6
.dw ZERO
.dw $-ZERO
.db 0
ONE:
.dw nativeWord
@ -1679,7 +1706,7 @@ ONE:
; ( a1 a2 -- b )
.db "SCMP"
.fill 3
.dw ONE
.dw $-ONE
.db 0
SCMP:
.dw nativeWord
@ -1694,7 +1721,7 @@ SCMP:
; ( n1 n2 -- f )
.db "CMP"
.fill 4
.dw SCMP
.dw $-SCMP
.db 0
CMP:
.dw nativeWord
@ -1712,7 +1739,7 @@ CMP:
; to after null-termination.
.db "SKIP?"
.fill 2
.dw CMP
.dw $-CMP
.db 0
CSKIP:
.dw nativeWord
@ -1770,7 +1797,7 @@ CSKIP:
; contain 3. Add this value to RS.
.db "(fbr)"
.fill 2
.dw CSKIP
.dw $-CSKIP
.db 0
FBR:
.dw nativeWord
@ -1784,7 +1811,7 @@ FBR:
.db "(bbr)"
.fill 2
.dw FBR
.dw $-FBR
.db 0
BBR:
.dw nativeWord
@ -1796,5 +1823,11 @@ BBR:
ld (IP), hl
jp next
; 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 "_______"
.dw $-BBR
.db 0
LATEST:
.dw BBR

View File

@ -1,12 +1,19 @@
( Z80 assembler )
: CODE
( same as CREATE, but with ROUTINE V )
WORD (entry)
ROUTINE V [LITN] ,
;
( Splits word into msb/lsb, lsb being on TOS )
: SPLITB
DUP 0x100 /
SWAP 0xff AND
;
: A, .X ;
( To debug, change C, to .X )
: A, C, ;
7 CONSTANT A
0 CONSTANT B
1 CONSTANT C
@ -122,3 +129,4 @@
( Specials )
: JRe, 0x18 A, 2 - A, ;
: JPNEXT, ROUTINE N [LITN] JPnn, ;