1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-02 12:30:55 +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 NOT ;
: < CMP 0 1 - = ; : < CMP 0 1 - = ;
: > CMP 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 ; IP, but we also take care of increasing it my 2 before jumping
next: next:
; Before we continue: are stacks within bounds? ; Before we continue: are stacks within bounds?
call chkPSRS call chkPS
call chkRS
ld de, (IP) ld de, (IP)
ld h, d ld h, d
ld l, e ld l, e
@ -158,9 +159,34 @@ abortUnknownWord:
.msg: .msg:
.db "unknown word", 0 .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" .db "BYE"
.fill 4 .fill 4
.dw ABORT .dw ABORTI
.db 0 .db 0
BYE: BYE:
.dw nativeWord .dw nativeWord
@ -180,19 +206,66 @@ BYE:
EMIT: EMIT:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
ld a, l ld a, l
call stdioPutC call stdioPutC
jp next 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 -- ) ; ( c port -- )
.db "PC!" .db "PC!"
.fill 4 .fill 4
.dw EMIT .dw PRINTI
.db 0 .db 0
PSTORE: PSTORE:
.dw nativeWord .dw nativeWord
pop bc pop bc
pop hl pop hl
call chkPS
out (c), l out (c), l
jp next jp next
@ -204,6 +277,7 @@ PSTORE:
PFETCH: PFETCH:
.dw nativeWord .dw nativeWord
pop bc pop bc
call chkPS
ld h, 0 ld h, 0
in l, (c) in l, (c)
push hl push hl
@ -216,6 +290,7 @@ PFETCH:
EXECUTE: EXECUTE:
.dw nativeWord .dw nativeWord
pop iy ; is a wordref pop iy ; is a wordref
call chkPS
ld l, (iy) ld l, (iy)
ld h, (iy+1) ld h, (iy+1)
; HL points to code pointer ; HL points to code pointer
@ -354,6 +429,7 @@ LITN:
ld de, NUMBER ld de, NUMBER
call DEinHL call DEinHL
pop de ; number from stack pop de ; number from stack
call chkPS
call DEinHL call DEinHL
ld (HERE), hl ld (HERE), hl
jp next jp next
@ -373,52 +449,62 @@ LITS:
ld (HERE), de ld (HERE), de
jp next jp next
.db "'" .db "(find)"
.fill 6 .fill 1
.dw LITS .dw LITS
.db 0 .db 0
APOS: FIND_:
.dw nativeWord .dw nativeWord
call readword call readword
call find call find
jr nz, .notfound jr z, .found
; not found
push hl
ld de, 0
push de push de
jp next jp next
.notfound: .found:
ld hl, .msg push de
call printstr ld de, 1
jp abort push de
.msg: jp next
.db "word not found", 0
.db "'"
.fill 6
.dw FIND_
.db 0
FIND:
.dw compiledWord
.dw FIND_
.dw CSKIP
.dw FINDERR
.dw EXIT
.db "[']" .db "[']"
.fill 4 .fill 4
.dw APOS .dw FIND
.db 0b01 ; IMMEDIATE .db 0b01 ; IMMEDIATE
APOSI: FINDI:
.dw nativeWord .dw compiledWord
call readword .dw FIND_
call find .dw CSKIP
jr nz, .notfound .dw FINDERR
ld hl, (HERE) .dw LITN
push de ; --> lvl 1 .dw EXIT
ld de, NUMBER
call DEinHL .db 0b10 ; UNWORD
pop de ; <-- lvl 1 FINDERR:
call DEinHL .dw compiledWord
ld (HERE), hl .dw DROP ; Drop str addr, we don't use it
jp next .dw LIT
.notfound:
ld hl, .msg
call printstr
jp abort
.msg:
.db "word not found", 0 .db "word not found", 0
.dw PRINT
.dw ABORT
; ( -- c ) ; ( -- c )
.db "KEY" .db "KEY"
.fill 4 .fill 4
.dw APOSI .dw FINDI
.db 0 .db 0
KEY: KEY:
.dw nativeWord .dw nativeWord
@ -476,31 +562,16 @@ INP:
.dw sysvarWord .dw sysvarWord
.dw INPUTPOS .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 -- ) ; ( n a -- )
.db "!" .db "!"
.fill 6 .fill 6
.dw DOT .dw INP
.db 0 .db 0
STORE: STORE:
.dw nativeWord .dw nativeWord
pop iy pop iy
pop hl pop hl
call chkPS
ld (iy), l ld (iy), l
ld (iy+1), h ld (iy+1), h
jp next jp next
@ -514,6 +585,7 @@ CSTORE:
.dw nativeWord .dw nativeWord
pop hl pop hl
pop de pop de
call chkPS
ld (hl), e ld (hl), e
jp next jp next
@ -525,6 +597,7 @@ CSTORE:
FETCH: FETCH:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
call intoHL call intoHL
push hl push hl
jp next jp next
@ -537,6 +610,7 @@ FETCH:
CFETCH: CFETCH:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
ld l, (hl) ld l, (hl)
ld h, 0 ld h, 0
push hl push hl
@ -560,6 +634,7 @@ DROP:
SWAP: SWAP:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
ex (sp), hl ex (sp), hl
push hl push hl
jp next jp next
@ -574,6 +649,7 @@ SWAP2:
pop de ; D pop de ; D
pop hl ; C pop hl ; C
pop bc ; B pop bc ; B
call chkPS
ex (sp), hl ; A in HL ex (sp), hl ; A in HL
push de ; D push de ; D
@ -589,6 +665,7 @@ SWAP2:
DUP: DUP:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
push hl push hl
push hl push hl
jp next jp next
@ -602,6 +679,7 @@ DUP2:
.dw nativeWord .dw nativeWord
pop hl ; B pop hl ; B
pop de ; A pop de ; A
call chkPS
push de push de
push hl push hl
push de push de
@ -617,6 +695,7 @@ OVER:
.dw nativeWord .dw nativeWord
pop hl ; B pop hl ; B
pop de ; A pop de ; A
call chkPS
push de push de
push hl push hl
push de push de
@ -633,6 +712,7 @@ OVER2:
pop de ; C pop de ; C
pop bc ; B pop bc ; B
pop iy ; A pop iy ; A
call chkPS
push iy ; A push iy ; A
push bc ; B push bc ; B
push de ; C push de ; C
@ -648,6 +728,7 @@ OVER2:
P2R: P2R:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
call pushRS call pushRS
jp next jp next
@ -703,6 +784,7 @@ PLUS:
.dw nativeWord .dw nativeWord
pop hl pop hl
pop de pop de
call chkPS
add hl, de add hl, de
push hl push hl
jp next jp next
@ -716,6 +798,7 @@ MINUS:
.dw nativeWord .dw nativeWord
pop de ; B pop de ; B
pop hl ; A pop hl ; A
call chkPS
or a ; reset carry or a ; reset carry
sbc hl, de sbc hl, de
push hl push hl
@ -730,32 +813,36 @@ MULT:
.dw nativeWord .dw nativeWord
pop de pop de
pop bc pop bc
call chkPS
call multDEBC call multDEBC
push hl push hl
jp next jp next
; ( a b -- c ) A / B
.db "/" .db "/MOD"
.fill 6 .fill 3
.dw MULT .dw MULT
.db 0 .db 0
DIV: DIVMOD:
.dw nativeWord .dw nativeWord
pop de pop de
pop hl pop hl
call chkPS
call divide call divide
push hl
push bc push bc
jp next jp next
; ( a1 a2 -- b ) ; ( a1 a2 -- b )
.db "SCMP" .db "SCMP"
.fill 3 .fill 3
.dw DIV .dw DIVMOD
.db 0 .db 0
SCMP: SCMP:
.dw nativeWord .dw nativeWord
pop de pop de
pop hl pop hl
call chkPS
call strcmp call strcmp
call flagsToBC call flagsToBC
push bc push bc
@ -770,6 +857,7 @@ CMP:
.dw nativeWord .dw nativeWord
pop hl pop hl
pop de pop de
call chkPS
or a ; clear carry or a ; clear carry
sbc hl, de sbc hl, de
call flagsToBC call flagsToBC
@ -783,6 +871,7 @@ CMP:
CSKIP: CSKIP:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS
ld a, h ld a, h
or l or l
jp z, next ; False, do nothing. 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. "*I*" in description indicates an IMMEDIATE word.
*** Defining words *** *** 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 : x ... -- Define a new word
; R:I -- Exit a colon definition ; R:I -- Exit a colon definition
, n -- Write n in HERE and advance it. , 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 ['] 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. ( -- *I* Comment. Ignore rest of line until ")" is read.
ALLOT n -- Move HERE by n bytes ALLOT n -- Move HERE by n bytes
C, b -- Write byte b in HERE and advance it. 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. atom's cell.
(bbr) -- Branches backward by the number specified in its (bbr) -- Branches backward by the number specified in its
atom's cell. 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. AGAIN I:a -- *I* Jump backwards to preceeding BEGIN.
BEGIN -- I:a *I* Marker for backward branching with AGAIN. BEGIN -- I:a *I* Marker for backward branching with AGAIN.
ELSE I:a -- *I* Compiles a (fbr) and set branching cell at a. 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 b - a -> c
* a b -- c a * b -> c * a b -- c a * b -> 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 *** *** Logic ***
= n1 n2 -- f Push true if n1 == n2 = 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 KEY input, however, is direct. Regardless of the input buffer's state, KEY will
return the next typed key. return the next typed key.
(print) a -- Print string at addr a.
. n -- Print n in its decimal form . 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 EMIT c -- Spit char c to output stream
IN> -- a Address of variable containing current pos in input IN> -- a Address of variable containing current pos in input
buffer. buffer.

View File

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

View File

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

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 ; Return address of scratchpad in HL
pad: pad:
ld hl, (HERE) ld hl, (HERE)
@ -215,12 +543,12 @@ HLPointsUNWORD:
pop hl pop hl
ret 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: flagsToBC:
ld bc, 0 ld bc, 0
ret z ; equal ret z ; equal
inc bc inc bc
ret c ; > ret m ; >
; < ; <
dec bc dec bc
dec bc dec bc

View File

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

View File

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