mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 14:20:56 +11:00
Compare commits
No commits in common. "b72901175e4590fbe0a881a0fa122e51b431b1b9" and "5d5517ac44f884e9395f320213856e09a8814b61" have entirely different histories.
b72901175e
...
5d5517ac44
@ -47,51 +47,3 @@
|
||||
: = 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
|
||||
;
|
||||
|
||||
@ -18,8 +18,7 @@
|
||||
; IP, but we also take care of increasing it my 2 before jumping
|
||||
next:
|
||||
; Before we continue: are stacks within bounds?
|
||||
call chkPS
|
||||
call chkRS
|
||||
call chkPSRS
|
||||
ld de, (IP)
|
||||
ld h, d
|
||||
ld l, e
|
||||
@ -159,34 +158,9 @@ 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 ABORTI
|
||||
.dw ABORT
|
||||
.db 0
|
||||
BYE:
|
||||
.dw nativeWord
|
||||
@ -206,66 +180,19 @@ 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 PRINTI
|
||||
.dw EMIT
|
||||
.db 0
|
||||
PSTORE:
|
||||
.dw nativeWord
|
||||
pop bc
|
||||
pop hl
|
||||
call chkPS
|
||||
out (c), l
|
||||
jp next
|
||||
|
||||
@ -277,7 +204,6 @@ PSTORE:
|
||||
PFETCH:
|
||||
.dw nativeWord
|
||||
pop bc
|
||||
call chkPS
|
||||
ld h, 0
|
||||
in l, (c)
|
||||
push hl
|
||||
@ -290,7 +216,6 @@ PFETCH:
|
||||
EXECUTE:
|
||||
.dw nativeWord
|
||||
pop iy ; is a wordref
|
||||
call chkPS
|
||||
ld l, (iy)
|
||||
ld h, (iy+1)
|
||||
; HL points to code pointer
|
||||
@ -429,7 +354,6 @@ LITN:
|
||||
ld de, NUMBER
|
||||
call DEinHL
|
||||
pop de ; number from stack
|
||||
call chkPS
|
||||
call DEinHL
|
||||
ld (HERE), hl
|
||||
jp next
|
||||
@ -449,62 +373,52 @@ LITS:
|
||||
ld (HERE), de
|
||||
jp next
|
||||
|
||||
.db "(find)"
|
||||
.fill 1
|
||||
.db "'"
|
||||
.fill 6
|
||||
.dw LITS
|
||||
.db 0
|
||||
FIND_:
|
||||
APOS:
|
||||
.dw nativeWord
|
||||
call readword
|
||||
call find
|
||||
jr z, .found
|
||||
; not found
|
||||
push hl
|
||||
ld de, 0
|
||||
jr nz, .notfound
|
||||
push de
|
||||
jp next
|
||||
.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
|
||||
.notfound:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp abort
|
||||
.msg:
|
||||
.db "word not found", 0
|
||||
|
||||
.db "[']"
|
||||
.fill 4
|
||||
.dw FIND
|
||||
.dw APOS
|
||||
.db 0b01 ; IMMEDIATE
|
||||
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
|
||||
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:
|
||||
.db "word not found", 0
|
||||
.dw PRINT
|
||||
.dw ABORT
|
||||
|
||||
; ( -- c )
|
||||
.db "KEY"
|
||||
.fill 4
|
||||
.dw FINDI
|
||||
.dw APOSI
|
||||
.db 0
|
||||
KEY:
|
||||
.dw nativeWord
|
||||
@ -562,16 +476,31 @@ 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 INP
|
||||
.dw DOT
|
||||
.db 0
|
||||
STORE:
|
||||
.dw nativeWord
|
||||
pop iy
|
||||
pop hl
|
||||
call chkPS
|
||||
ld (iy), l
|
||||
ld (iy+1), h
|
||||
jp next
|
||||
@ -585,7 +514,6 @@ CSTORE:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
pop de
|
||||
call chkPS
|
||||
ld (hl), e
|
||||
jp next
|
||||
|
||||
@ -597,7 +525,6 @@ CSTORE:
|
||||
FETCH:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
call intoHL
|
||||
push hl
|
||||
jp next
|
||||
@ -610,7 +537,6 @@ FETCH:
|
||||
CFETCH:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
ld l, (hl)
|
||||
ld h, 0
|
||||
push hl
|
||||
@ -634,7 +560,6 @@ DROP:
|
||||
SWAP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
ex (sp), hl
|
||||
push hl
|
||||
jp next
|
||||
@ -649,7 +574,6 @@ SWAP2:
|
||||
pop de ; D
|
||||
pop hl ; C
|
||||
pop bc ; B
|
||||
call chkPS
|
||||
|
||||
ex (sp), hl ; A in HL
|
||||
push de ; D
|
||||
@ -665,7 +589,6 @@ SWAP2:
|
||||
DUP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
push hl
|
||||
push hl
|
||||
jp next
|
||||
@ -679,7 +602,6 @@ DUP2:
|
||||
.dw nativeWord
|
||||
pop hl ; B
|
||||
pop de ; A
|
||||
call chkPS
|
||||
push de
|
||||
push hl
|
||||
push de
|
||||
@ -695,7 +617,6 @@ OVER:
|
||||
.dw nativeWord
|
||||
pop hl ; B
|
||||
pop de ; A
|
||||
call chkPS
|
||||
push de
|
||||
push hl
|
||||
push de
|
||||
@ -712,7 +633,6 @@ OVER2:
|
||||
pop de ; C
|
||||
pop bc ; B
|
||||
pop iy ; A
|
||||
call chkPS
|
||||
push iy ; A
|
||||
push bc ; B
|
||||
push de ; C
|
||||
@ -728,7 +648,6 @@ OVER2:
|
||||
P2R:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
call pushRS
|
||||
jp next
|
||||
|
||||
@ -784,7 +703,6 @@ PLUS:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
pop de
|
||||
call chkPS
|
||||
add hl, de
|
||||
push hl
|
||||
jp next
|
||||
@ -798,7 +716,6 @@ MINUS:
|
||||
.dw nativeWord
|
||||
pop de ; B
|
||||
pop hl ; A
|
||||
call chkPS
|
||||
or a ; reset carry
|
||||
sbc hl, de
|
||||
push hl
|
||||
@ -813,36 +730,32 @@ MULT:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
pop bc
|
||||
call chkPS
|
||||
call multDEBC
|
||||
push hl
|
||||
jp next
|
||||
|
||||
|
||||
.db "/MOD"
|
||||
.fill 3
|
||||
; ( a b -- c ) A / B
|
||||
.db "/"
|
||||
.fill 6
|
||||
.dw MULT
|
||||
.db 0
|
||||
DIVMOD:
|
||||
DIV:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
pop hl
|
||||
call chkPS
|
||||
call divide
|
||||
push hl
|
||||
push bc
|
||||
jp next
|
||||
|
||||
; ( a1 a2 -- b )
|
||||
.db "SCMP"
|
||||
.fill 3
|
||||
.dw DIVMOD
|
||||
.dw DIV
|
||||
.db 0
|
||||
SCMP:
|
||||
.dw nativeWord
|
||||
pop de
|
||||
pop hl
|
||||
call chkPS
|
||||
call strcmp
|
||||
call flagsToBC
|
||||
push bc
|
||||
@ -857,7 +770,6 @@ CMP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
pop de
|
||||
call chkPS
|
||||
or a ; clear carry
|
||||
sbc hl, de
|
||||
call flagsToBC
|
||||
@ -871,7 +783,6 @@ CMP:
|
||||
CSKIP:
|
||||
.dw nativeWord
|
||||
pop hl
|
||||
call chkPS
|
||||
ld a, h
|
||||
or l
|
||||
jp z, next ; False, do nothing.
|
||||
|
||||
@ -32,14 +32,12 @@ 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. If not found, aborts
|
||||
' x -- a Push addr of word x to a.
|
||||
['] x -- *I* Like "'", but spits the addr as a number
|
||||
literal. If not found, aborts.
|
||||
literal.
|
||||
( -- *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.
|
||||
@ -75,8 +73,6 @@ 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.
|
||||
@ -125,8 +121,6 @@ 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
|
||||
@ -150,12 +144,7 @@ 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.
|
||||
|
||||
@ -2,6 +2,10 @@
|
||||
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"
|
||||
|
||||
@ -37,25 +37,25 @@ skipRS:
|
||||
ret
|
||||
|
||||
; Verifies that SP and RS are within bounds. If it's not, call ABORT
|
||||
chkRS:
|
||||
chkPSRS:
|
||||
push ix \ pop hl
|
||||
push de ; --> lvl 1
|
||||
ld de, RS_ADDR
|
||||
or a ; clear carry
|
||||
sbc hl, de
|
||||
pop de ; <-- lvl 1
|
||||
jp c, abortUnderflow
|
||||
ret
|
||||
|
||||
chkPS:
|
||||
push hl
|
||||
jr c, .underflow
|
||||
ld hl, (INITIAL_SP)
|
||||
; We have the return address for this very call on the stack and
|
||||
; protected registers. Let's compensate
|
||||
dec hl \ dec hl
|
||||
; We have the return address for this very call on the stack. Let's
|
||||
; compensate
|
||||
dec hl \ dec hl
|
||||
or a ; clear carry
|
||||
sbc hl, sp
|
||||
pop hl
|
||||
ret nc ; (INITIAL_SP) >= SP? good
|
||||
jp abortUnderflow
|
||||
.underflow:
|
||||
; underflow
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp abort
|
||||
.msg:
|
||||
.db "stack underflow", 0
|
||||
|
||||
@ -1,331 +1,3 @@
|
||||
; *** 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)
|
||||
@ -543,12 +215,12 @@ HLPointsUNWORD:
|
||||
pop hl
|
||||
ret
|
||||
|
||||
; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
|
||||
; Checks flags Z and C and sets BC to 0 if Z, 1 if C and -1 otherwise
|
||||
flagsToBC:
|
||||
ld bc, 0
|
||||
ret z ; equal
|
||||
inc bc
|
||||
ret m ; >
|
||||
ret c ; >
|
||||
; <
|
||||
dec bc
|
||||
dec bc
|
||||
|
||||
@ -23,6 +23,10 @@
|
||||
.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"
|
||||
|
||||
@ -14,6 +14,10 @@
|
||||
.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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user