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

Compare commits

..

5 Commits

Author SHA1 Message Date
Virgil Dupras
b335e538b4 Move "forth" folder to project's root folder
It's not really an App.
2020-03-18 22:25:44 -04:00
Virgil Dupras
ae6334906c forth: inline kernel's core and str units 2020-03-18 22:18:07 -04:00
Virgil Dupras
548facac0b forth: Implement "(parseh)" 2020-03-18 21:52:55 -04:00
Virgil Dupras
d874f20278 forth: Add "DO" and "LOOP"
Also, un-IMMEDIATE "LITN" it didn't make any sense.
2020-03-18 20:04:44 -04:00
Virgil Dupras
587d1d0d69 forth: add word "UNTIL" 2020-03-18 16:39:22 -04:00
16 changed files with 171 additions and 53 deletions

View File

@ -39,6 +39,8 @@ path to giving Collapse OS a try.
through a serial port. through a serial port.
* `emul`: Emulated applications, such as zasm and the shell. * `emul`: Emulated applications, such as zasm and the shell.
* `tests`: Automated test suite for the whole project. * `tests`: Automated test suite for the whole project.
* `forth`: Forth is slowly taking over this project (see issue #4). It comes
from this folder.
## Status ## Status

View File

@ -1,10 +0,0 @@
.inc "user.h"
jp forthMain
.inc "core.asm"
.equ FORTH_RAMSTART RAMSTART
.inc "forth/main.asm"
.inc "forth/util.asm"
.inc "forth/stack.asm"
.inc "forth/dict.asm"
RAMSTART:

View File

@ -1,18 +0,0 @@
( requires core )
: (parsec) ( a -- n f )
( apostrophe is ASCII 39 )
DUP C@ 39 = NOT IF 0 EXIT THEN ( -- a 0 )
DUP 2 + C@ 39 = NOT IF 0 EXIT THEN ( -- a 0 )
( surrounded by apos, good, return )
1 + C@ 1 ( -- n 1 )
;
: (parse) ( a -- n )
(parsec) NOT SKIP? EXIT
(parsed) NOT SKIP? EXIT
( nothing works )
ABORT" unknown word! "
;
' (parse) (parse*) !

View File

@ -7,8 +7,8 @@ AVRABIN = zasm/avra
SHELLAPPS = zasm ed SHELLAPPS = zasm ed
SHELLTGTS = ${SHELLAPPS:%=cfsin/%} SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
# Those Forth source files are in a particular order # Those Forth source files are in a particular order
FORTHSRCS = core.fs parse.fs fmt.fs FORTHSRCS = core.fs str.fs parse.fs fmt.fs
FORTHSRC_PATHS = ${FORTHSRCS:%=$(APPS)/forth/%} FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%}
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
OBJS = emul.o libz80/libz80.o OBJS = emul.o libz80/libz80.o
SHELLOBJS = $(OBJS) $(CFSPACK_OBJ) SHELLOBJS = $(OBJS) $(CFSPACK_OBJ)
@ -28,7 +28,7 @@ shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h
$(CC) shell/shell.c $(SHELLOBJS) -o $@ $(CC) shell/shell.c $(SHELLOBJS) -o $@
forth/forth0.bin: forth/glue0.asm $(ZASMBIN) forth/forth0.bin: forth/glue0.asm $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null $(ZASMBIN) $(KERNEL) ../forth < forth/glue0.asm | tee $@ > /dev/null
forth/forth0-bin.h: forth/forth0.bin forth/forth0-bin.h: forth/forth0.bin
./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null ./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null
@ -43,7 +43,7 @@ forth/core.bin: $(FORTHSRC_PATHS) forth/stage1
cat $(FORTHSRC_PATHS) | ./forth/stage1 | tee $@ > /dev/null cat $(FORTHSRC_PATHS) | ./forth/stage1 | tee $@ > /dev/null
forth/forth1.bin: forth/glue1.asm forth/core.bin $(ZASMBIN) forth/forth1.bin: forth/glue1.asm forth/core.bin $(ZASMBIN)
$(ZASMBIN) $(KERNEL) $(APPS) forth/core.bin < forth/glue1.asm | tee $@ > /dev/null $(ZASMBIN) $(KERNEL) ../forth forth/core.bin < forth/glue1.asm | tee $@ > /dev/null
forth/forth1-bin.h: forth/forth1.bin forth/forth1-bin.h: forth/forth1.bin
./bin2c.sh KERNEL < forth/forth1.bin | tee $@ > /dev/null ./bin2c.sh KERNEL < forth/forth1.bin | tee $@ > /dev/null

View File

@ -15,8 +15,6 @@
jp init jp init
.inc "core.asm"
.inc "str.asm"
.equ STDIO_RAMSTART RAMSTART .equ STDIO_RAMSTART RAMSTART
.equ STDIO_GETC emulGetC .equ STDIO_GETC emulGetC
@ -24,10 +22,10 @@
.inc "stdio.asm" .inc "stdio.asm"
.equ FORTH_RAMSTART STDIO_RAMEND .equ FORTH_RAMSTART STDIO_RAMEND
.inc "forth/main.asm" .inc "main.asm"
.inc "forth/util.asm" .inc "util.asm"
.inc "forth/stack.asm" .inc "stack.asm"
.inc "forth/dict.asm" .inc "dict.asm"
init: init:

View File

@ -6,19 +6,16 @@
jp init jp init
.inc "core.asm"
.inc "str.asm"
.equ STDIO_RAMSTART RAMSTART .equ STDIO_RAMSTART RAMSTART
.equ STDIO_GETC emulGetC .equ STDIO_GETC emulGetC
.equ STDIO_PUTC emulPutC .equ STDIO_PUTC emulPutC
.inc "stdio.asm" .inc "stdio.asm"
.equ FORTH_RAMSTART STDIO_RAMEND .equ FORTH_RAMSTART STDIO_RAMEND
.inc "forth/main.asm" .inc "main.asm"
.inc "forth/util.asm" .inc "util.asm"
.inc "forth/stack.asm" .inc "stack.asm"
.inc "forth/dict.asm" .inc "dict.asm"
init: init:

View File

@ -3,20 +3,19 @@
: +! SWAP OVER @ + SWAP ! ; : +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ; : ALLOT HERE +! ;
: C, H C! 1 ALLOT ; : C, H C! 1 ALLOT ;
: COMPILE ' LITN ['] , , ; IMMEDIATE
: BEGIN H ; IMMEDIATE : BEGIN H ; IMMEDIATE
: COMPILE ' ['] LITN EXECUTE ['] , , ; IMMEDIATE
: AGAIN COMPILE (bbr) H -^ C, ; IMMEDIATE : AGAIN COMPILE (bbr) H -^ C, ; IMMEDIATE
: UNTIL COMPILE SKIP? COMPILE (bbr) H -^ C, ; IMMEDIATE
: NOT 1 SWAP SKIP? EXIT 0 * ; : NOT 1 SWAP SKIP? EXIT 0 * ;
: ( BEGIN LITS ) WORD SCMP NOT SKIP? AGAIN ; IMMEDIATE : ( BEGIN LITS ) WORD SCMP NOT UNTIL ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me? ( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments Ah, voice at last! Some lines above need comments
BTW: Forth lines limited to 64 cols because of default BTW: Forth lines limited to 64 cols because of default
input buffer size in Collapse OS input buffer size in Collapse OS
COMPILE; Tough one. Get addr of caller word (example above COMPILE; Tough one. Get addr of caller word (example above
(bbr)) and then call LITN on it. However, LITN is an (bbr)) and then call LITN on it.
immediate and has to be indirectly executed. Then, write
a reference to "," so that this word is written to HERE.
NOT: a bit convulted because we don't have IF yet ) NOT: a bit convulted because we don't have IF yet )
@ -48,3 +47,20 @@
: > CMP 1 = ; : > CMP 1 = ;
: / /MOD SWAP DROP ; : / /MOD SWAP DROP ;
: MOD /MOD DROP ; : MOD /MOD DROP ;
( In addition to pushing H this compiles 2 >R so that loop variables are sent
to PS at runtime )
: DO
COMPILE SWAP COMPILE >R COMPILE >R
H
; IMMEDIATE
( One could think that we should have a sub word to avoid all these COMPILE,
but we can't because otherwise it messes with the RS )
: LOOP
COMPILE R> 1 LITN COMPILE + COMPILE DUP COMPILE >R
COMPILE I' COMPILE = COMPILE SKIP? COMPILE (bbr)
H -^ C,
COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
; IMMEDIATE

View File

@ -444,7 +444,7 @@ ISIMMED:
.db "LITN" .db "LITN"
.fill 3 .fill 3
.dw ISIMMED .dw ISIMMED
.db 1 ; IMMEDIATE .db 0
LITN: LITN:
.dw nativeWord .dw nativeWord
ld hl, (HERE) ld hl, (HERE)

View File

@ -50,7 +50,7 @@ CONSTANT x n -- Creates cell x that when called pushes its value
DOES> -- See description at top of file DOES> -- See description at top of file
IMMED? a -- f Checks whether wordref at a is immediate. IMMED? a -- f Checks whether wordref at a is immediate.
IMMEDIATE -- Flag the latest defined word as immediate. IMMEDIATE -- Flag the latest defined word as immediate.
LITN n -- *I* Inserts number from TOS as a literal LITN n -- Write number n as a literal.
VARIABLE c -- Creates cell x with 2 bytes allocation. VARIABLE c -- Creates cell x with 2 bytes allocation.
Compilation vs meta-compilation. When you compile a word with "[COMPILE] foo", Compilation vs meta-compilation. When you compile a word with "[COMPILE] foo",
@ -91,6 +91,7 @@ SKIP? f -- If f is true, skip the execution of the next atom.
Use this right before ";" and you're gonna have a Use this right before ";" and you're gonna have a
bad time. bad time.
THEN I:a -- *I* Set branching cell at a. THEN I:a -- *I* Set branching cell at a.
UNTIL f -- *I* Jump backwards to BEGIN if f is *false*.
*** Parameter Stack *** *** Parameter Stack ***
DROP a -- DROP a --
@ -140,6 +141,7 @@ NOT f -- f Push the logical opposite of f
*** Strings *** *** Strings ***
LITS x -- a Read following LIT and push its addr to a LITS x -- a Read following LIT and push its addr to a
SCMP a1 a2 -- n Compare strings a1 and a2. See CMP SCMP a1 a2 -- n Compare strings a1 and a2. See CMP
SLEN a -- n Push length of str at a.
*** I/O *** *** I/O ***

55
forth/parse.fs Normal file
View File

@ -0,0 +1,55 @@
( requires core, str )
( string being sent to parse routines are always null
terminated )
: (parsec) ( a -- n f )
( apostrophe is ASCII 39 )
DUP C@ 39 = NOT IF 0 EXIT THEN ( a 0 )
DUP 2 + C@ 39 = NOT IF 0 EXIT THEN ( a 0 )
( surrounded by apos, good, return )
1 + C@ 1 ( n 1 )
;
( returns negative value on error )
: hexdig ( c -- n )
( '0' is ASCII 48 )
48 -
DUP 0 < IF EXIT THEN ( bad )
DUP 10 < IF EXIT THEN ( good )
( 'a' is ASCII 97. 59 = 97 - 48 )
49 -
DUP 0 < IF EXIT THEN ( bad )
DUP 6 < IF 10 + EXIT THEN ( good )
( bad )
255 -
;
: (parseh) ( a -- n f )
( '0': ASCII 0x30 'x': 0x78 0x7830: 30768 )
DUP @ 30768 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0x" suffix )
2 +
( validate slen )
DUP SLEN ( a l )
DUP 0 = IF DROP 0 EXIT THEN ( a 0 )
4 > IF DROP 0 EXIT THEN ( a 0 )
0 ( a r )
BEGIN
OVER C@
DUP 0 = IF DROP SWAP DROP 1 EXIT THEN ( r, 1 )
hexdig ( a r n )
DUP 0 < IF DROP DROP 1 EXIT THEN ( a 0 )
SWAP 16 * + ( a r*16+n )
SWAP 1 + SWAP ( a+1 r )
AGAIN
;
: (parse) ( a -- n )
(parsec) NOT SKIP? EXIT
(parseh) NOT SKIP? EXIT
(parsed) NOT SKIP? EXIT
( nothing works )
ABORT" unknown word! "
;
' (parse) (parse*) !

7
forth/str.fs Normal file
View File

@ -0,0 +1,7 @@
: SLEN ( a -- n )
DUP ( astart aend )
BEGIN
DUP C@ 0 = IF -^ EXIT THEN
1 +
AGAIN
;

View File

@ -6,6 +6,43 @@
; give us an idea of Forth's compactness. ; give us an idea of Forth's compactness.
; These routines below are copy/paste from apps/lib. ; These routines below are copy/paste from apps/lib.
; Ensures that Z is unset (more complicated than it sounds...)
; There are often better inline alternatives, either replacing rets with
; appropriate jmps, or if an 8 bit register is known to not be 0, an inc
; then a dec. If a is nonzero, 'or a' is optimal.
unsetZ:
or a ;if a nonzero, Z reset
ret nz
cp 1 ;if a is zero, Z reset
ret
; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
; ld must be done little endian, so least significant byte first.
intoHL:
push de
ld e, (hl)
inc hl
ld d, (hl)
ex de, hl
pop de
ret
intoDE:
ex de, hl
call intoHL
ex de, hl ; de preserved by intoHL, so no push/pop needed
ret
; add the value of A into HL
; affects carry flag according to the 16-bit addition, Z, S and P untouched.
addHL:
push de
ld d, 0
ld e, a
add hl, de
pop de
ret
; make Z the opposite of what it is now ; make Z the opposite of what it is now
toggleZ: toggleZ:
jp z, unsetZ jp z, unsetZ
@ -57,6 +94,38 @@ strcmp:
; early, set otherwise) ; early, set otherwise)
ret ret
; Compares strings pointed to by HL and DE up to A count of characters. If
; equal, Z is set. If not equal, Z is reset.
strncmp:
push bc
push hl
push de
ld b, a
.loop:
ld a, (de)
cp (hl)
jr nz, .end ; not equal? break early. NZ is carried out
; to the called
cp 0 ; If our chars are null, stop the cmp
jr z, .end ; The positive result will be carried to the
; caller
inc hl
inc de
djnz .loop
; We went through all chars with success, but our current Z flag is
; unset because of the cp 0. Let's do a dummy CP to set the Z flag.
cp a
.end:
pop de
pop hl
pop bc
; Because we don't call anything else than CP that modify the Z flag,
; our Z value will be that of the last cp (reset if we broke the loop
; early, set otherwise)
ret
; Given a string at (HL), move HL until it points to the end of that string. ; Given a string at (HL), move HL until it points to the end of that string.
strskip: strskip:
push bc push bc