mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-26 09:38:06 +11:00
Compare commits
9 Commits
5d5517ac44
...
b72901175e
Author | SHA1 | Date | |
---|---|---|---|
|
b72901175e | ||
|
d91af99fde | ||
|
3a70dff53d | ||
|
25b6e75cf7 | ||
|
a40926d710 | ||
|
6314c60ede | ||
|
549cf74e9d | ||
|
017a469d9c | ||
|
839d7097e7 |
@ -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
|
||||||
|
;
|
||||||
|
@ -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.
|
||||||
|
@ -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.
|
||||||
|
@ -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"
|
||||||
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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"
|
||||||
|
@ -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"
|
||||||
|
Loading…
Reference in New Issue
Block a user