izaya/collapseos
1
0
Fork 0
mirror of https://github.com/hsoft/collapseos.git synced 2024-12-28 08:18:05 +11:00
Code Issues Releases Wiki Activity

forth: add "UNWORD" flag

Browse Source 
Also, reorder word fields so that the flag field is more easily accessible.
This commit is contained in:
Virgil Dupras 2020-03-12 11:39:27 -04:00
parent a8e573c84a
commit ff281f69a8
5 changed files with 131 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
apps/forth/dict.asm
View File

@ -1,7 +1,7 @@
; A dictionary entry has this structure:
; - 7b name (zero-padded)
; - 1b flags (bit 0: IMMEDIATE)
; - 2b prev pointer
; - 1b flags (bit 0: IMMEDIATE. bit 1: UNWORD)
; - 2b code pointer
; - Parameter field (PF)
;
@ -9,6 +9,11 @@
; with IY pointing to the PF. They themselves are expected to end by jumping
; to the address at the top of the Return Stack. They will usually do so with
; "jp exit".
;
; That's for "regular" words (words that are part of the dict chain). There are
; also "special words", for example NUMBER, LIT, BRANCH, that have a slightly
; different structure. They're also a pointer to an executable, but as for the
; other fields, the only one they have is the "flags" field.
; Execute a word containing native code at its PF address (PFA)
nativeWord:
@ -65,6 +70,7 @@ branchWord:
pop de
jp exit
.db 0b10 ; Flags
BRANCH:
.dw branchWord
@ -82,6 +88,7 @@ cbranchWord:
ld (ix+1), h
jp exit
.db 0b10 ; Flags
CBRANCH:
.dw cbranchWord
@ -102,6 +109,8 @@ numberWord:
ld (ix+1), h
push de
jp exit
.db 0b10 ; Flags
NUMBER:
.dw numberWord
@ -119,6 +128,8 @@ litWord:
jp abort
.msg:
.db "undefined word", 0
.db 0b10 ; Flags
LIT:
.dw litWord
@ -143,16 +154,18 @@ exit:
; ( R:I -- )
.db "QUIT"
.fill 4
.fill 3
.dw EXIT
.db 0
QUIT:
.dw nativeWord
quit:
jp forthRdLine
.db "ABORT"
.fill 3
.fill 2
.dw QUIT
.db 0
ABORT:
.dw nativeWord
abort:
@ -163,8 +176,9 @@ ABORTREF:
.dw ABORT
.db "BYE"
.fill 5
.fill 4
.dw ABORT
.db 0
BYE:
.dw nativeWord
; Goodbye Forth! Before we go, let's restore the stack
@ -177,8 +191,9 @@ BYE:
; ( c -- )
.db "EMIT"
.fill 4
.fill 3
.dw BYE
.db 0
EMIT:
.dw nativeWord
pop hl
@ -188,8 +203,9 @@ EMIT:
; ( c port -- )
.db "PC!"
.fill 5
.fill 4
.dw EMIT
.db 0
PSTORE:
.dw nativeWord
pop bc
@ -199,8 +215,9 @@ PSTORE:
; ( port -- c )
.db "PC@"
.fill 5
.fill 4
.dw PSTORE
.db 0
PFETCH:
.dw nativeWord
pop bc
@ -211,8 +228,8 @@ PFETCH:
; ( addr -- )
.db "EXECUTE"
.db 0
.dw PFETCH
.db 0
EXECUTE:
.dw nativeWord
pop iy ; is a wordref
@ -226,8 +243,9 @@ executeCodeLink:
jp (hl) ; go!
.db ":"
.fill 7
.fill 6
.dw EXECUTE
.db 0
DEFINE:
.dw nativeWord
call entryhead
@ -273,8 +291,9 @@ DEFINE:
.db "DOES>"
.fill 3
.fill 2
.dw DEFINE
.db 0
DOES:
.dw nativeWord
; We run this when we're in an entry creation context. Many things we
@ -296,21 +315,21 @@ DOES:
.db "IMMEDIA"
.db 0
.dw DOES
.db 0
IMMEDIATE:
.dw nativeWord
ld hl, (CURRENT)
dec hl
dec hl
dec hl
inc (hl)
set FLAG_IMMED, (hl)
jp exit
; ( n -- )
.db "LITERAL"
.db 1 ; IMMEDIATE
.dw IMMEDIATE
.db 1 ; IMMEDIATE
LITERAL:
.dw nativeWord
ld hl, (CMPDST)
@ -323,8 +342,9 @@ LITERAL:
; ( -- c )
.db "KEY"
.fill 5
.fill 4
.dw LITERAL
.db 0
KEY:
.dw nativeWord
call stdioGetC
@ -334,8 +354,9 @@ KEY:
jp exit
.db "CREATE"
.fill 2
.fill 1
.dw KEY
.db 0
CREATE:
.dw nativeWord
call entryhead
@ -349,23 +370,25 @@ CREATE:
jp exit
.db "HERE"
.fill 4
.fill 3
.dw CREATE
.db 0
HERE_: ; Caution: conflicts with actual variable name
.dw sysvarWord
.dw HERE
.db "CURRENT"
.db 0
.dw HERE_
.db 0
CURRENT_:
.dw sysvarWord
.dw CURRENT
; ( n -- )
.db "."
.fill 7
.fill 6
.dw CURRENT_
.db 0
DOT:
.dw nativeWord
pop de
@ -379,8 +402,9 @@ DOT:
; ( n a -- )
.db "!"
.fill 7
.fill 6
.dw DOT
.db 0
STORE:
.dw nativeWord
pop iy
@ -391,8 +415,9 @@ STORE:
; ( n a -- )
.db "C!"
.fill 6
.fill 5
.dw STORE
.db 0
CSTORE:
.dw nativeWord
pop hl
@ -402,8 +427,9 @@ CSTORE:
; ( a -- n )
.db "@"
.fill 7
.fill 6
.dw CSTORE
.db 0
FETCH:
.dw nativeWord
pop hl
@ -413,8 +439,9 @@ FETCH:
; ( a -- c )
.db "C@"
.fill 6
.fill 5
.dw FETCH
.db 0
CFETCH:
.dw nativeWord
pop hl
@ -425,8 +452,9 @@ CFETCH:
; ( -- a )
.db "LIT@"
.fill 4
.fill 3
.dw CFETCH
.db 0
LITFETCH:
.dw nativeWord
call readLITTOS
@ -435,8 +463,9 @@ LITFETCH:
; ( a b -- b a )
.db "SWAP"
.fill 4
.fill 3
.dw LITFETCH
.db 0
SWAP:
.dw nativeWord
pop hl
@ -446,8 +475,9 @@ SWAP:
; ( a b c d -- c d a b )
.db "2SWAP"
.fill 3
.fill 2
.dw SWAP
.db 0
SWAP2:
.dw nativeWord
pop de ; D
@ -462,8 +492,9 @@ SWAP2:
; ( a -- a a )
.db "DUP"
.fill 5
.fill 4
.dw SWAP2
.db 0
DUP:
.dw nativeWord
pop hl
@ -473,8 +504,9 @@ DUP:
; ( a b -- a b a b )
.db "2DUP"
.fill 4
.fill 3
.dw DUP
.db 0
DUP2:
.dw nativeWord
pop hl ; B
@ -487,8 +519,9 @@ DUP2:
; ( a b -- a b a )
.db "OVER"
.fill 4
.fill 3
.dw DUP2
.db 0
OVER:
.dw nativeWord
pop hl ; B
@ -500,8 +533,9 @@ OVER:
; ( a b c d -- a b c d a b )
.db "2OVER"
.fill 3
.fill 2
.dw OVER
.db 0
OVER2:
.dw nativeWord
pop hl ; D
@ -518,8 +552,9 @@ OVER2:
; ( a b -- c ) A + B
.db "+"
.fill 7
.fill 6
.dw OVER2
.db 0
PLUS:
.dw nativeWord
pop hl
@ -530,8 +565,9 @@ PLUS:
; ( a b -- c ) A - B
.db "-"
.fill 7
.fill 6
.dw PLUS
.db 0
MINUS:
.dw nativeWord
pop de ; B
@ -543,8 +579,9 @@ MINUS:
; ( a b -- c ) A * B
.db "*"
.fill 7
.fill 6
.dw MINUS
.db 0
MULT:
.dw nativeWord
pop de
@ -555,8 +592,9 @@ MULT:
; ( a b -- c ) A / B
.db "/"
.fill 7
.fill 6
.dw MULT
.db 0
DIV:
.dw nativeWord
pop de
@ -567,8 +605,9 @@ DIV:
; ( a1 a2 -- b )
.db "SCMP"
.fill 4
.fill 3
.dw DIV
.db 0
SCMP:
.dw nativeWord
pop de
@ -580,8 +619,9 @@ SCMP:
; ( n1 n2 -- f )
.db "CMP"
.fill 5
.fill 4
.dw SCMP
.db 0
CMP:
.dw nativeWord
pop hl
@ -594,8 +634,8 @@ CMP:
.db "IF"
.fill 5
.db 1 ; IMMEDIATE
.dw CMP
.db 1 ; IMMEDIATE
IF:
.dw nativeWord
; Spit a conditional branching atom, followed by an empty 1b cell. Then,
@ -611,8 +651,8 @@ IF:
.db "ELSE"
.fill 3
.db 1 ; IMMEDIATE
.dw IF
.db 1 ; IMMEDIATE
ELSE:
.dw nativeWord
; First, let's set IF's branching cell.
@ -637,8 +677,8 @@ ELSE:
.db "THEN"
.fill 3
.db 1 ; IMMEDIATE
.dw ELSE
.db 1 ; IMMEDIATE
THEN:
.dw nativeWord
; See comments in IF and ELSE
@ -652,8 +692,8 @@ THEN:
jp exit
.db "RECURSE"
.db 0
.dw THEN
.db 0
RECURSE:
.dw nativeWord
call popRS

7
apps/forth/main.asm
View File

@ -8,6 +8,13 @@
; Offset of the code link relative to the beginning of the word
.equ CODELINK_OFFSET NAMELEN+3
; Flags for the "flag field" of the word structure
; IMMEDIATE word
.equ FLAG_IMMED 0
; This wordref is not a regular word (it's not preceeded by a name). It's one
; of the NUMBER, LIT, BRANCH etc. entities.
.equ FLAG_UNWORD 1
; *** Variables ***
.equ INITIAL_SP FORTH_RAMSTART
.equ CURRENT @+2

82
apps/forth/util.asm
View File

@ -87,13 +87,6 @@ HLPointsEXIT:
pop de
ret
HLPointsQUIT:
push de
ld de, QUIT
call HLPointsDE
pop de
ret
; Skip the compword where HL is currently pointing. If it's a regular word,
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
; to after null-termination.
@ -176,16 +169,9 @@ readLIT:
ex de, hl
ret
.notLIT:
; Alright, not a literal, but is it a word? If it's not a number, then
; it's a word.
call HLPointsNUMBER
jr z, .notWord
call HLPointsBRANCH
jr z, .notWord
call HLPointsEXIT
jr z, .notWord
call HLPointsQUIT
jr z, .notWord
; Alright, not a literal, but is it a word?
call HLPointsUNWORD
jr nz, .notWord
; Not a number, then it's a word. Copy word to pad and point to it.
push hl ; --> lvl 1. we need it to set DE later
call intoHL
@ -233,18 +219,6 @@ readLITTOS:
pop de
ret
; For DE being a wordref, move DE to the previous wordref.
; Z is set if DE point to 0 (no entry). NZ if not.
prev:
dec de \ dec de ; prev field
call intoDE
; DE points to prev. Is it zero?
xor a
or d
or e
; Z will be set if DE is zero
ret
; Find the entry corresponding to word where (HL) points to and sets DE to
; point to that entry.
; Z if found, NZ if not.
@ -264,7 +238,7 @@ find:
call strncmp
pop de ; <-- lvl 1, return to wordref
jr z, .end ; found
call prev
call .prev
jr nz, .inner
; Z set? end of dict unset Z
inc a
@ -273,6 +247,18 @@ find:
pop hl
ret
; For DE being a wordref, move DE to the previous wordref.
; Z is set if DE point to 0 (no entry). NZ if not.
.prev:
dec de \ dec de \ dec de ; prev field
call intoDE
; DE points to prev. Is it zero?
xor a
or d
or e
; Z will be set if DE is zero
ret
; Write compiled data from HL into IY, advancing IY at the same time.
wrCompHL:
ld (iy), l
@ -291,13 +277,11 @@ entryhead:
ld de, (CURRENT)
ld a, NAMELEN
call addHL
xor a ; IMMED
call DEinHL
; Set word flags: not IMMED, not UNWORD, so it's 0
xor a
ld (hl), a
inc hl
ld (hl), e
inc hl
ld (hl), d
inc hl
ld (CURRENT), hl
ld (HERE), hl
xor a ; set Z
@ -306,16 +290,10 @@ entryhead:
; Sets Z if wordref at HL is of the IMMEDIATE type
HLisIMMED:
dec hl
dec hl
dec hl
bit FLAG_IMMED, (hl)
inc hl
; We need an invert flag. We want to Z to be set when flag is non-zero.
ld a, 1
and (hl)
dec a ; if A was 1, Z is set. Otherwise, Z is unset
inc hl
inc hl
inc hl
ret
jp toggleZ
; Sets Z if wordref at (HL) is of the IMMEDIATE type
HLPointsIMMED:
@ -325,6 +303,22 @@ HLPointsIMMED:
pop hl
ret
; Sets Z if wordref at HL is of the UNWORD type
HLisUNWORD:
dec hl
bit FLAG_UNWORD, (hl)
inc hl
; We need an invert flag. We want to Z to be set when flag is non-zero.
jp toggleZ
; Sets Z if wordref at (HL) is of the IMMEDIATE type
HLPointsUNWORD:
push hl
call intoHL
call HLisUNWORD
pop hl
ret
; Checks flags Z and C and sets BC to 0 if Z, 1 if C and -1 otherwise
flagsToBC:
ld bc, 0

7
apps/lib/util.asm
View File

@ -105,3 +105,10 @@ strlen:
dec a
pop bc
ret
; make Z the opposite of what it is now
toggleZ:
jp z, unsetZ
cp a
ret

6
apps/zasm/util.asm
View File

@ -24,12 +24,6 @@ subDEFromHL:
pop af
ret
; make Z the opposite of what it is now
toggleZ:
jp z, unsetZ
cp a
ret
; Compares strings pointed to by HL and DE up to A count of characters in a
; case-insensitive manner.
; If equal, Z is set. If not equal, Z is reset.