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

Compare commits

...

9 Commits

Author SHA1 Message Date
Virgil Dupras
b72901175e forth: Word-ify "[']" and "'" 2020-03-17 16:17:51 -04:00
Virgil Dupras
d91af99fde forth: make "'" push 0 when not finding a word 2020-03-17 15:54:17 -04:00
Virgil Dupras
3a70dff53d forth: add word 'ABORT"' 2020-03-17 15:31:15 -04:00
Virgil Dupras
25b6e75cf7 forth: add words "."" and "(print)" 2020-03-17 15:22:13 -04:00
Virgil Dupras
a40926d710 forth: check PS everywhere
It turns out we have to...
2020-03-17 14:56:08 -04:00
Virgil Dupras
6314c60ede forth: add word ".X" 2020-03-17 14:05:53 -04:00
Virgil Dupras
549cf74e9d forth: inline code from "apps/lib"
Forth-ification of Collapse OS goes forward. What will happen is that assembly
code in apps/ will become Forth code. The concept of an assembler code library
will become obsolete.

However, Forth's core use some of that code. To facilitate the transition, I'm
inlining that code directly in Forth's code.
2020-03-17 12:49:06 -04:00
Virgil Dupras
017a469d9c forth: Forth-ify "." 2020-03-17 12:26:28 -04:00
Virgil Dupras
839d7097e7 forth: add words "MOD" and "/MOD" 2020-03-16 22:36:29 -04:00
8 changed files with 546 additions and 82 deletions

View File

@ -47,3 +47,51 @@
: = CMP NOT ;
: < CMP 0 1 - = ;
: > CMP 1 = ;
: / /MOD SWAP DROP ;
: MOD /MOD DROP ;
( Format numbers )
( TODO FORGET this word )
: PUSHDGTS
999 SWAP ( stop indicator )
DUP 0 = IF '0' EXIT THEN ( 0 is a special case )
BEGIN
DUP 0 = IF DROP EXIT THEN
10 /MOD ( r q )
SWAP '0' + SWAP ( d q )
AGAIN
;
: . ( n -- )
( handle negative )
( that "0 1 -" thing is because we don't parse negative
number correctly yet. )
DUP 0 < IF '-' EMIT 0 1 - * THEN
PUSHDGTS
BEGIN
DUP '9' > IF DROP EXIT THEN ( stop indicator, we're done )
EMIT
AGAIN
;
: PUSHDGTS
999 SWAP ( stop indicator )
DUP 0 = IF '0' EXIT THEN ( 0 is a special case )
BEGIN
DUP 0 = IF DROP EXIT THEN
16 /MOD ( r q )
SWAP ( r q )
DUP 9 > IF 10 - 'a' +
ELSE '0' + THEN ( q d )
SWAP ( d q )
AGAIN
;
: .X ( n -- )
( For hex display, there are no negatives )
PUSHDGTS
BEGIN
DUP 'f' > IF DROP EXIT THEN ( stop indicator, we're done )
EMIT
AGAIN
;

View File

@ -18,7 +18,8 @@
; IP, but we also take care of increasing it my 2 before jumping
next:
; Before we continue: are stacks within bounds?
call chkPSRS
call chkPS
call chkRS
ld de, (IP)
ld h, d
ld l, e
@ -158,9 +159,34 @@ abortUnknownWord:
.msg:
.db "unknown word", 0
abortUnderflow:
ld hl, .msg
jr abortMsg
.msg:
.db "stack underflow", 0
.db "ABORT", '"'
.fill 1
.dw ABORT
.db 1 ; IMMEDIATE
ABORTI:
.dw compiledWord
.dw PRINTI
.dw .private
.dw EXIT
.db 0b10 ; UNWORD
.private:
.dw nativeWord
ld hl, (HERE)
ld de, ABORT
call DEinHL
ld (HERE), hl
jp next
.db "BYE"
.fill 4
.dw ABORT
.dw ABORTI
.db 0
BYE:
.dw nativeWord
@ -180,19 +206,66 @@ BYE:
EMIT:
.dw nativeWord
pop hl
call chkPS
ld a, l
call stdioPutC
jp next
.db "(print)"
.dw EMIT
.db 0
PRINT:
.dw nativeWord
pop hl
call chkPS
call printstr
jp next
.db '.', '"'
.fill 5
.dw PRINT
.db 1 ; IMMEDIATE
PRINTI:
.dw nativeWord
ld hl, (HERE)
ld de, LIT
call DEinHL
ex de, hl ; (HERE) now in DE
ld hl, (INPUTPOS)
.loop:
ld a, (hl)
or a ; null? not cool
jp z, abort
cp '"'
jr z, .loopend
ld (de), a
inc hl
inc de
jr .loop
.loopend:
inc hl ; inputpos to char afterwards
ld (INPUTPOS), hl
; null-terminate LIT
inc de
xor a
ld (de), a
ex de, hl ; (HERE) in HL
ld de, PRINT
call DEinHL
ld (HERE), hl
jp next
; ( c port -- )
.db "PC!"
.fill 4
.dw EMIT
.dw PRINTI
.db 0
PSTORE:
.dw nativeWord
pop bc
pop hl
call chkPS
out (c), l
jp next
@ -204,6 +277,7 @@ PSTORE:
PFETCH:
.dw nativeWord
pop bc
call chkPS
ld h, 0
in l, (c)
push hl
@ -216,6 +290,7 @@ PFETCH:
EXECUTE:
.dw nativeWord
pop iy ; is a wordref
call chkPS
ld l, (iy)
ld h, (iy+1)
; HL points to code pointer
@ -354,6 +429,7 @@ LITN:
ld de, NUMBER
call DEinHL
pop de ; number from stack
call chkPS
call DEinHL
ld (HERE), hl
jp next
@ -373,52 +449,62 @@ LITS:
ld (HERE), de
jp next
.db "'"
.fill 6
.db "(find)"
.fill 1
.dw LITS
.db 0
APOS:
FIND_:
.dw nativeWord
call readword
call find
jr nz, .notfound
jr z, .found
; not found
push hl
ld de, 0
push de
jp next
.notfound:
ld hl, .msg
call printstr
jp abort
.msg:
.db "word not found", 0
.found:
push de
ld de, 1
push de
jp next
.db "'"
.fill 6
.dw FIND_
.db 0
FIND:
.dw compiledWord
.dw FIND_
.dw CSKIP
.dw FINDERR
.dw EXIT
.db "[']"
.fill 4
.dw APOS
.dw FIND
.db 0b01 ; IMMEDIATE
APOSI:
.dw nativeWord
call readword
call find
jr nz, .notfound
ld hl, (HERE)
push de ; --> lvl 1
ld de, NUMBER
call DEinHL
pop de ; <-- lvl 1
call DEinHL
ld (HERE), hl
jp next
.notfound:
ld hl, .msg
call printstr
jp abort
.msg:
FINDI:
.dw compiledWord
.dw FIND_
.dw CSKIP
.dw FINDERR
.dw LITN
.dw EXIT
.db 0b10 ; UNWORD
FINDERR:
.dw compiledWord
.dw DROP ; Drop str addr, we don't use it
.dw LIT
.db "word not found", 0
.dw PRINT
.dw ABORT
; ( -- c )
.db "KEY"
.fill 4
.dw APOSI
.dw FINDI
.db 0
KEY:
.dw nativeWord
@ -476,31 +562,16 @@ INP:
.dw sysvarWord
.dw INPUTPOS
; ( n -- )
.db "."
.fill 6
.dw INP
.db 0
DOT:
.dw nativeWord
pop de
; We check PS explicitly because it doesn't look nice to spew gibberish
; before aborting the stack underflow.
call chkPSRS
call pad
call fmtDecimalS
call printstr
jp next
; ( n a -- )
.db "!"
.fill 6
.dw DOT
.dw INP
.db 0
STORE:
.dw nativeWord
pop iy
pop hl
call chkPS
ld (iy), l
ld (iy+1), h
jp next
@ -514,6 +585,7 @@ CSTORE:
.dw nativeWord
pop hl
pop de
call chkPS
ld (hl), e
jp next
@ -525,6 +597,7 @@ CSTORE:
FETCH:
.dw nativeWord
pop hl
call chkPS
call intoHL
push hl
jp next
@ -537,6 +610,7 @@ FETCH:
CFETCH:
.dw nativeWord
pop hl
call chkPS
ld l, (hl)
ld h, 0
push hl
@ -560,6 +634,7 @@ DROP:
SWAP:
.dw nativeWord
pop hl
call chkPS
ex (sp), hl
push hl
jp next
@ -574,6 +649,7 @@ SWAP2:
pop de ; D
pop hl ; C
pop bc ; B
call chkPS
ex (sp), hl ; A in HL
push de ; D
@ -589,6 +665,7 @@ SWAP2:
DUP:
.dw nativeWord
pop hl
call chkPS
push hl
push hl
jp next
@ -602,6 +679,7 @@ DUP2:
.dw nativeWord
pop hl ; B
pop de ; A
call chkPS
push de
push hl
push de
@ -617,6 +695,7 @@ OVER:
.dw nativeWord
pop hl ; B
pop de ; A
call chkPS
push de
push hl
push de
@ -633,6 +712,7 @@ OVER2:
pop de ; C
pop bc ; B
pop iy ; A
call chkPS
push iy ; A
push bc ; B
push de ; C
@ -648,6 +728,7 @@ OVER2:
P2R:
.dw nativeWord
pop hl
call chkPS
call pushRS
jp next
@ -703,6 +784,7 @@ PLUS:
.dw nativeWord
pop hl
pop de
call chkPS
add hl, de
push hl
jp next
@ -716,6 +798,7 @@ MINUS:
.dw nativeWord
pop de ; B
pop hl ; A
call chkPS
or a ; reset carry
sbc hl, de
push hl
@ -730,32 +813,36 @@ MULT:
.dw nativeWord
pop de
pop bc
call chkPS
call multDEBC
push hl
jp next
; ( a b -- c ) A / B
.db "/"
.fill 6
.db "/MOD"
.fill 3
.dw MULT
.db 0
DIV:
DIVMOD:
.dw nativeWord
pop de
pop hl
call chkPS
call divide
push hl
push bc
jp next
; ( a1 a2 -- b )
.db "SCMP"
.fill 3
.dw DIV
.dw DIVMOD
.db 0
SCMP:
.dw nativeWord
pop de
pop hl
call chkPS
call strcmp
call flagsToBC
push bc
@ -770,6 +857,7 @@ CMP:
.dw nativeWord
pop hl
pop de
call chkPS
or a ; clear carry
sbc hl, de
call flagsToBC
@ -783,6 +871,7 @@ CMP:
CSKIP:
.dw nativeWord
pop hl
call chkPS
ld a, h
or l
jp z, next ; False, do nothing.

View File

@ -32,12 +32,14 @@ directly, but as part of another word.
"*I*" in description indicates an IMMEDIATE word.
*** Defining words ***
(find) x -- a f Read word x and find it in dict. If found, f=1 and
a = wordref. If not found, f=0 and a = string addr.
: x ... -- Define a new 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 -- a Push addr of word x to a. If not found, aborts
['] x -- *I* Like "'", but spits the addr as a number
literal.
literal. If not found, aborts.
( -- *I* Comment. Ignore rest of line until ")" is read.
ALLOT n -- Move HERE by n bytes
C, b -- Write byte b in HERE and advance it.
@ -73,6 +75,8 @@ input stream is executed immediately. In this context, branching doesn't work.
atom's cell.
(bbr) -- Branches backward by the number specified in its
atom's cell.
ABORT -- Resets PS and RS and returns to interpreter
ABORT" x" -- *I* Compiles a ." followed by a ABORT.
AGAIN I:a -- *I* Jump backwards to preceeding BEGIN.
BEGIN -- I:a *I* Marker for backward branching with AGAIN.
ELSE I:a -- *I* Compiles a (fbr) and set branching cell at a.
@ -121,6 +125,8 @@ H -- a HERE @
-^ a b -- c b - a -> c
* a b -- c a * b -> c
/ a b -- c a / b -> c
MOD a b -- c a % b -> c
/MOD a b -- r q r:remainder q:quotient
*** Logic ***
= n1 n2 -- f Push true if n1 == n2
@ -144,7 +150,12 @@ wait until another line is entered.
KEY input, however, is direct. Regardless of the input buffer's state, KEY will
return the next typed key.
(print) a -- Print string at addr a.
. n -- Print n in its decimal form
.X n -- Print n in its hexadecimal form. In hex, numbers
." xxx" -- *I* Compiles string literal xxx followed by a call
to (print)
are never considered negative. "-1 .X -> ffff"
EMIT c -- Spit char c to output stream
IN> -- a Address of variable containing current pos in input
buffer.

View File

@ -2,10 +2,6 @@
jp forthMain
.inc "core.asm"
.inc "lib/util.asm"
.inc "lib/parse.asm"
.inc "lib/ari.asm"
.inc "lib/fmt.asm"
.equ FORTH_RAMSTART RAMSTART
.inc "forth/main.asm"
.inc "forth/util.asm"

View File

@ -37,25 +37,25 @@ skipRS:
ret
; Verifies that SP and RS are within bounds. If it's not, call ABORT
chkPSRS:
chkRS:
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
jp c, abortUnderflow
ret
chkPS:
push hl
ld hl, (INITIAL_SP)
; We have the return address for this very call on the stack. Let's
; compensate
; We have the return address for this very call on the stack and
; protected registers. Let's compensate
dec hl \ dec hl
dec hl \ dec hl
or a ; clear carry
sbc hl, sp
pop hl
ret nc ; (INITIAL_SP) >= SP? good
.underflow:
; underflow
ld hl, .msg
call printstr
jp abort
.msg:
.db "stack underflow", 0
jp abortUnderflow

View File

@ -1,3 +1,331 @@
; *** Collapse OS lib copy ***
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
; Forth and the concept of ASM libs will become obsolete. To facilitate this
; transition, I make, right now, a copy of the routines actually used by Forth's
; native core. This also has the effect of reducing binary size right now and
; give us an idea of Forth's compactness.
; These routines below are copy/paste from apps/lib.
; make Z the opposite of what it is now
toggleZ:
jp z, unsetZ
cp a
ret
; Copy string from (HL) in (DE), that is, copy bytes until a null char is
; encountered. The null char is also copied.
; HL and DE point to the char right after the null char.
strcpyM:
ld a, (hl)
ld (de), a
inc hl
inc de
or a
jr nz, strcpyM
ret
; Like strcpyM, but preserve HL and DE
strcpy:
push hl
push de
call strcpyM
pop de
pop hl
ret
; Compares strings pointed to by HL and DE until one of them hits its null char.
; If equal, Z is set. If not equal, Z is reset. C is set if HL > DE
strcmp:
push hl
push de
.loop:
ld a, (de)
cp (hl)
jr nz, .end ; not equal? break early. NZ is carried out
; to the caller
or a ; If our chars are null, stop the cmp
inc hl
inc de
jr nz, .loop ; Z is carried through
.end:
pop de
pop hl
; 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.
strskip:
push bc
ex af, af'
xor a ; look for null char
ld b, a
ld c, a
cpir ; advances HL regardless of comparison, so goes one too far
dec hl
ex af, af'
pop bc
ret
; Borrowed from Tasty Basic by Dimitri Theulings (GPL).
; Divide HL by DE, placing the result in BC and the remainder in HL.
divide:
push hl ; --> lvl 1
ld l, h ; divide h by de
ld h, 0
call .dv1
ld b, c ; save result in b
ld a, l ; (remainder + l) / de
pop hl ; <-- lvl 1
ld h, a
.dv1:
ld c, 0xff ; result in c
.dv2:
inc c ; dumb routine
call .subde ; divide using subtract and count
jr nc, .dv2
add hl, de
ret
.subde:
ld a, l
sub e ; subtract de from hl
ld l, a
ld a, h
sbc a, d
ld h, a
ret
; DE * BC -> DE (high) and HL (low)
multDEBC:
ld hl, 0
ld a, 0x10
.loop:
add hl, hl
rl e
rl d
jr nc, .noinc
add hl, bc
jr nc, .noinc
inc de
.noinc:
dec a
jr nz, .loop
ret
; Parse the hex char at A and extract it's 0-15 numerical value. Put the result
; in A.
;
; On success, the carry flag is reset. On error, it is set.
parseHex:
; First, let's see if we have an easy 0-9 case
add a, 0xc6 ; maps '0'-'9' onto 0xf6-0xff
sub 0xf6 ; maps to 0-9 and carries if not a digit
ret nc
and 0xdf ; converts lowercase to uppercase
add a, 0xe9 ; map 0x11-x017 onto 0xFA - 0xFF
sub 0xfa ; map onto 0-6
ret c
; we have an A-F digit
add a, 10 ; C is clear, map back to 0xA-0xF
ret
; Parse string at (HL) as a decimal value and return value in DE.
; Reads as many digits as it can and stop when:
; 1 - A non-digit character is read
; 2 - The number overflows from 16-bit
; HL is advanced to the character following the last successfully read char.
; Error conditions are:
; 1 - There wasn't at least one character that could be read.
; 2 - Overflow.
; Sets Z on success, unset on error.
parseDecimal:
; First char is special: it has to succeed.
ld a, (hl)
; Parse the decimal char at A and extract it's 0-9 numerical value. Put the
; result in A.
; On success, the carry flag is reset. On error, it is set.
add a, 0xff-'9' ; maps '0'-'9' onto 0xf6-0xff
sub 0xff-9 ; maps to 0-9 and carries if not a digit
ret c ; Error. If it's C, it's also going to be NZ
; During this routine, we switch between HL and its shadow. On one side,
; we have HL the string pointer, and on the other side, we have HL the
; numerical result. We also use EXX to preserve BC, saving us a push.
parseDecimalSkip: ; enter here to skip parsing the first digit
exx ; HL as a result
ld h, 0
ld l, a ; load first digit in without multiplying
.loop:
exx ; HL as a string pointer
inc hl
ld a, (hl)
exx ; HL as a numerical result
; same as other above
add a, 0xff-'9'
sub 0xff-9
jr c, .end
ld b, a ; we can now use a for overflow checking
add hl, hl ; x2
sbc a, a ; a=0 if no overflow, a=0xFF otherwise
ld d, h
ld e, l ; de is x2
add hl, hl ; x4
rla
add hl, hl ; x8
rla
add hl, de ; x10
rla
ld d, a ; a is zero unless there's an overflow
ld e, b
add hl, de
adc a, a ; same as rla except affects Z
; Did we oveflow?
jr z, .loop ; No? continue
; error, NZ already set
exx ; HL is now string pointer, restore BC
; HL points to the char following the last success.
ret
.end:
push hl ; --> lvl 1, result
exx ; HL as a string pointer, restore BC
pop de ; <-- lvl 1, result
cp a ; ensure Z
ret
; Parse string at (HL) as a hexadecimal value without the "0x" prefix and
; return value in DE.
; HL is advanced to the character following the last successfully read char.
; Sets Z on success.
parseHexadecimal:
ld a, (hl)
call parseHex ; before "ret c" is "sub 0xfa" in parseHex
; so carry implies not zero
ret c ; we need at least one char
push bc
ld de, 0
ld b, d
ld c, d
; The idea here is that the 4 hex digits of the result can be represented "bdce",
; where each register holds a single digit. Then the result is simply
; e = (c << 4) | e, d = (b << 4) | d
; However, the actual string may be of any length, so when loading in the most
; significant digit, we don't know which digit of the result it actually represents
; To solve this, after a digit is loaded into a (and is checked for validity),
; all digits are moved along, with e taking the latest digit.
.loop:
dec b
inc b ; b should be 0, else we've overflowed
jr nz, .end ; Z already unset if overflow
ld b, d
ld d, c
ld c, e
ld e, a
inc hl
ld a, (hl)
call parseHex
jr nc, .loop
ld a, b
add a, a \ add a, a \ add a, a \ add a, a
or d
ld d, a
ld a, c
add a, a \ add a, a \ add a, a \ add a, a
or e
ld e, a
xor a ; ensure z
.end:
pop bc
ret
; Parse string at (HL) as a binary value (010101) without the "0b" prefix and
; return value in E. D is always zero.
; HL is advanced to the character following the last successfully read char.
; Sets Z on success.
parseBinaryLiteral:
ld de, 0
.loop:
ld a, (hl)
add a, 0xff-'1'
sub 0xff-1
jr c, .end
rlc e ; sets carry if overflow, and affects Z
ret c ; Z unset if carry set, since bit 0 of e must be set
add a, e
ld e, a
inc hl
jr .loop
.end:
; HL is properly set
xor a ; ensure Z
ret
; Parses the string at (HL) and returns the 16-bit value in DE. The string
; can be a decimal literal (1234), a hexadecimal literal (0x1234) or a char
; literal ('X').
; HL is advanced to the character following the last successfully read char.
;
; As soon as the number doesn't fit 16-bit any more, parsing stops and the
; number is invalid. If the number is valid, Z is set, otherwise, unset.
parseLiteral:
ld de, 0 ; pre-fill
ld a, (hl)
cp 0x27 ; apostrophe
jr z, .char
; inline parseDecimalDigit
add a, 0xc6 ; maps '0'-'9' onto 0xf6-0xff
sub 0xf6 ; maps to 0-9 and carries if not a digit
ret c
; a already parsed so skip first few instructions of parseDecimal
jp nz, parseDecimalSkip
; maybe hex, maybe binary
inc hl
ld a, (hl)
inc hl ; already place it for hex or bin
cp 'x'
jr z, parseHexadecimal
cp 'b'
jr z, parseBinaryLiteral
; nope, just a regular decimal
dec hl \ dec hl
jp parseDecimal
; Parse string at (HL) and, if it is a char literal, sets Z and return
; corresponding value in E. D is always zero.
; HL is advanced to the character following the last successfully read char.
;
; A valid char literal starts with ', ends with ' and has one character in the
; middle. No escape sequence are accepted, but ''' will return the apostrophe
; character.
.char:
inc hl
ld e, (hl) ; our result
inc hl
cp (hl)
; advance HL and return if good char
inc hl
ret z
; Z unset and there's an error
; In all error conditions, HL is advanced by 3. Rewind.
dec hl \ dec hl \ dec hl
; NZ already set
ret
; *** Forth-specific part ***
; Return address of scratchpad in HL
pad:
ld hl, (HERE)
@ -215,12 +543,12 @@ HLPointsUNWORD:
pop hl
ret
; Checks flags Z and C and sets BC to 0 if Z, 1 if C and -1 otherwise
; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
flagsToBC:
ld bc, 0
ret z ; equal
inc bc
ret c ; >
ret m ; >
; <
dec bc
dec bc

View File

@ -23,10 +23,6 @@
.equ STDIO_PUTC emulPutC
.inc "stdio.asm"
.inc "lib/util.asm"
.inc "lib/parse.asm"
.inc "lib/ari.asm"
.inc "lib/fmt.asm"
.equ FORTH_RAMSTART STDIO_RAMEND
.inc "forth/main.asm"
.inc "forth/util.asm"

View File

@ -14,10 +14,6 @@
.equ STDIO_PUTC emulPutC
.inc "stdio.asm"
.inc "lib/util.asm"
.inc "lib/parse.asm"
.inc "lib/ari.asm"
.inc "lib/fmt.asm"
.equ FORTH_RAMSTART STDIO_RAMEND
.inc "forth/main.asm"
.inc "forth/util.asm"