initial full commit

This commit is contained in:
mgcaret 2019-07-01 10:33:44 -07:00
parent 3721765c27
commit 50ae7f1361
40 changed files with 14433 additions and 0 deletions

24
LICENSE Normal file
View File

@ -0,0 +1,24 @@
Except where noted in individual files/functions the following license applies
to OF816:
Copyright 2019 Michael Guidero
Redistribution and use in source and binary forms, with or without modification, are permitted
provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this list of
conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or other materials provided
with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

41
README.md Normal file
View File

@ -0,0 +1,41 @@
# OF816
OF816 is a [65C816](https://www.westerndesigncenter.com/wdc/w65c816s-chip.cfm)
Forth implementation heavily inspired by
[Open Firmware (IEEE 1275-1994)](https://www.openfirmware.info/Welcome_to_OpenBIOS).
Note that OF816 is *not* an Open Firmware implmentation (yet), but it has the
potential (and groundwork has been done) for it to become one.
## Features
Among its many features are:
* Mostly platform-independent. OF816 can be ported easily to new systems.
* Ports currently exist for the W65C816SXB and the Apple IIgs.
* New ports require the implementation of a handful of routines.
* Simple instantiation of one or more Forths in a system.
* 32-bit cells.
* Optional [FCode](https://www.openfirmware.info/Forth/FCode) support
(less Device Tree and Package functions).
* [ANS Forth](http://lars.nocrew.org/dpans/dpans.htm)
* Core, most of Core Ext, Exception, Search Order, and Search Order Ext word
sets.
* Smattering of words from other sets.
## Goal
The goal of OF816 is to help get 65C816-based projects off the ground in terms
of development and testing. With a little effort it can be brought up on a new
system and used to play around with new hardware.
OF816 is not designed for speed. While reasonably performant, the primary goal
was compatibility with 32-bit Open Firmware's core word set, cell size, and
FCode. This allows the possibility of re-using existing Forth source and FCode
to develop hardware drivers, and potentially developing OF816 into a full Open
Firmware implementation.
## Resources
In addition to the links above, please see the ``LICENSE`` file, ``docs\``, and
the directories under ``platforms\``.
OF816 is licensed under a two-clause BSD license.

158
asm/compiler.s Normal file
View File

@ -0,0 +1,158 @@
; Compiler helpers & primitives
; Compile a byte to the dictionary
; preserves registers
.proc _cbytea
phy
ldy #$0000
sep #SHORT_A
sta [DHERE],y
rep #SHORT_A
inc DHERE
bne :+
inc DHERE+2
: ply
rts
.endproc
; Compile a 16-bit word
.proc _cworda
jsr _cbytea
xba
jsr _cbytea
xba
rts
.endproc
; Compile a 32-bit cell
.proc _ccellay
pha
tya
jsr _cworda
pla
jsr _cworda
rts
.endproc
; Make a word link in the dictionary, stores a link to the previous word into the
; dictionary, and sets LAST to this link
.proc _w_link
ldy #SV_CURRENT+2
lda [SYSVARS],y ; get CURRENT (compiler) wordlist address
sta YR+2
dey
dey
lda [SYSVARS],y
sta YR
ldy #$0002
lda [YR],y ; get LAST entry for the compiler word list
pha ; save on stack
dey
dey
lda [YR],y
pha
lda DHERE ; get HERE
sta [YR],y ; and put into CURRENT wordlist
iny
iny
lda DHERE+2
sta [YR],y
ply ; get the old LAST for the compiler word list
pla
jsr _ccellay ; and compile the link
rts
.endproc
; make a dictionary entry, return with flags/XT address in AY
.proc _mkentry
jsr _2parm
jsr _popxr ; name length
jsr _popwr ; name address
lda XR
cmp #NAMEMSK
bcs badword
clc ; see if we are in danger of putting the new
adc DHERE ; word's first several bytes across a bank boundary
bcs nextbank ; yes we it will
clc
adc #(4+1+1+4) ; (link size + name len byte + flag byte + jsl )
bcc :+ ; it won't, just go make the entry
nextbank: stz DHERE ; move dictionary pointer to next bank
inc DHERE+2
: jsr _w_link ; make link, sets LAST to HERE
lda XR
ora #$80
jsr _cbytea ; compile name length
ldy #$0000
: cpy XR
bcs done
lda [WR],y
and #$7F ; normalize
jsr _cupper ; and convert to upper case
jsr _cbytea
iny
bne :-
done: lda DHERE+2
ldy DHERE
pha
phy
lda #$00
jsr _cbytea ; default flags
ply
pla
rts
badword: ldy #<-19
lda #>-19
jmp _throway
.endproc
.proc _lmkentry
jsr _mkentry
rtl
.endproc
.if 0
; Compile data pointed at [WR], length in XR to dictionary
.proc _cdata
ldy #.loword(func)
lda #.hiword(func)
jmp _str_op_ay
func: jsr _cbytea
clc
rts
.endproc
; Compile (c-addr u) at top of stack into dictionary
.proc _csdata
ldy #.loword(_cdata::func)
lda #.hiword(_cdata::func)
jmp _str_op_ays
.endproc
.endif
; Compile a JSL to the dictionary
; with target in AY
.proc _cjsl
pha
phy
lda #opJSL
doit: jsr _cbytea
pla
jsr _cworda
pla
jsr _cbytea
rts
.endproc
; Compile a JSL to the dictionary
; with target in AY
.proc _cjml
pha
phy
lda #opJML
bra _cjsl::doit
.endproc

58
asm/env-dictionary.s Normal file
View File

@ -0,0 +1,58 @@
; Environmental Queries dictionary
; See config.inc for the options that control the conditionals here
; If max_search_order is > 0, then more entries or overridden entries
; can be placed into the environmental queries dictionary by doing:
; $ENV?-WL SET-CURRENT and then defining the new values (usually via
; VALUE or 2VALUE).
dstart "env"
; magic word in case user makes this the only dictionary in the search order.
; it will bail the user out by executing the FORTH word
.if max_search_order > 0
dword XYZZY,"XYZZY",F_IMMED
.else
hword XYZZY,"XYZZY",F_IMMED
.endif
ENTER
.dword FORTH
EXIT
eword
.if env_query_level > 0
; Environmental queries
denvq xCOUNTEDSTR,"/COUNTED-STRING",$FF
denvq xHOLD,"/HOLD",word_buf_size
.if pad_size > 0
denvq xPAD,"/PAD",pad_size
.endif
denvq xADDRU,"ADDRESS-UNIT-BITS",8
denvq xFLOORED,"FLOORED",$FFFFFFFF
denvq xMAXCHAR,"MAX-CHAR",$FF
denvq xMAXD,"MAX-D",$FFFFFFFF,$7FFFFFFF
denvq xMAXN,"MAX-N",$7FFFFFFF
denvq xMAXU,"MAX-U",$FFFFFFFF
denvq xMAXUD,"MAX-UD",$FFFFFFFF,$FFFFFFFF
denvq xRSTKC,"RETURN-STACK-CELLS",64
denvq xSTKC,"STACK-CELLS",64
.if env_query_level > 1
denvq xCORE,"CORE",$FFFFFFFF
denvq xEXCEPTION,"EXCEPTION",$FFFFFFFF
denvq xEXCEPTION_EXT,"EXCEPTION-EXT",$FFFFFFFF
.endif
.if include_fcode
denvq xFCODE,"FCODE",$FFFFFFFF
.endif
.if max_search_order > 0
.if env_query_level > 1
denvq xSEARCH_ORDER,"SEARCH-ORDER",$FFFFFFFF
denvq xSEARCH_ORDER_EXT,"SEARCH-ORDER-EXT",$FFFFFFFF
.endif
denvq xWORDLISTS,"WORDLISTS",max_search_order
.endif
.endif
dend

1372
asm/fcode.s Normal file

File diff suppressed because it is too large Load Diff

6914
asm/forth-dictionary.s Normal file

File diff suppressed because it is too large Load Diff

1078
asm/interpreter.s Normal file

File diff suppressed because it is too large Load Diff

384
asm/mathlib.s Normal file
View File

@ -0,0 +1,384 @@
; Math Library - I don't reinvent the wheel here for multiplication, division, etc.
; others have done great work before me and I credit them when I know who did it.
; 32-bit signed comparison
; C and Z reflect same comparision results as CMP instruction
.proc _stest32
lda STACKBASE+6,x
eor STACKBASE+2,x
bpl samesign
lda STACKBASE+4,x
cmp STACKBASE+0,x
lda STACKBASE+6,x
sbc STACKBASE+2,x
bvs :+
eor #$8000
: sec
rol
rts
samesign: lda STACKBASE+6,x
cmp STACKBASE+2,x
bcc :+ ; less than or not equal, done
bne :+
lda STACKBASE+4,x
cmp STACKBASE+0,x
: rts
.endproc
.proc _invertay
pha
tya
eor #$FFFF
tay
pla
eor #$FFFF
rts
.endproc
.proc _negateay
pha
tya
eor #$FFFF
clc
adc #$0001
tay
pla
eor #$FFFF
adc #$0000
rts
.endproc
.proc _invert
lda STACKBASE+0,x
eor #$FFFF
sta STACKBASE+0,x
lda STACKBASE+2,x
eor #$FFFF
sta STACKBASE+2,x
rts
.endproc
.proc _negate
jsr _invert
inc STACKBASE+0,x
bne :+
inc STACKBASE+2,x
: rts
.endproc
.proc _dinvert
jsr _invert
lda STACKBASE+4,x
eor #$FFFF
sta STACKBASE+4,x
lda STACKBASE+6,x
eor #$FFFF
sta STACKBASE+6,x
rts
.endproc
.proc _dnegate
jsr _dinvert
inc STACKBASE+4,x
bne :+
inc STACKBASE+6,x
bne :+
inc STACKBASE+0,x
bne :+
inc STACKBASE+2,x
: rts
.endproc
.proc _2abs
bit STACKBASE+2,x
bpl :+
jsr _negate
: jsr _swap
; fall-through
.endproc
.proc _abs
bit STACKBASE+2,x
bpl :+
jsr _negate
: rts
.endproc
.proc _signum
ldy #$FFFF
lda STACKBASE+2,x
bpl :+
sty STACKBASE+2,x
bra done
: iny
stz STACKBASE+2,x
ora STACKBASE+0,x
beq done
iny
done: sty STACKBASE+0,x
rts
.endproc
; 32-bit unsigned multiplication with 64-bit result
; right-shifting version by dclxvi
; scratch in YR, YR+2 (preserved)
.proc _umult
N = YR
lda N+2
pha
lda N
pha
lda #$00
sta N
ldy #32
lsr STACKBASE+6,x
ror STACKBASE+4,x
l1: bcc l2
clc
sta N+2
lda N
adc STACKBASE+0,x
sta N
lda N+2
adc STACKBASE+2,x
l2: ror
ror N
ror STACKBASE+6,x
ror STACKBASE+4,x
dey
bne l1
sta STACKBASE+2,x
lda N
sta STACKBASE+0,x
pla
sta N
pla
sta N+2
rts
.endproc
; 64-bit divided by 32-bit with 32-bit quotient and remainder
; Adapted from Garth's routine, just like everyone else :-)
; carry set if divison by zero or overflow
; ( d n -- r q )
; d.hi = stack(4,6), d.low = stack(8,10), n=stack(0,2)
.proc _umdivmod
CARRY = YR
SCRATCH = YR+2
.if 1 ; shortcut 32-bit by 32-bit division
lda STACKBASE+4,x
ora STACKBASE+6,x
beq _udivmod32 ; go do faster 32-bit divide
.endif
lda SCRATCH
pha
lda CARRY
pha
sec ; first, check for overflow and division by 0
lda STACKBASE+4,x
sbc STACKBASE+0,x
lda STACKBASE+6,x
sbc STACKBASE+2,x
bcs overflow
lda #33 ; 32 bits + 1
sta XR
loop: rol STACKBASE+8,x
rol STACKBASE+10,x
dec XR
beq done
rol STACKBASE+4,x
rol STACKBASE+6,x
stz CARRY
rol CARRY
sec
lda STACKBASE+4,x
sbc STACKBASE+0,x
sta SCRATCH
lda STACKBASE+6,x
sbc STACKBASE+2,x
tay
lda CARRY
sbc #0
bcc loop
lda SCRATCH
sta STACKBASE+4,x
sty STACKBASE+6,x
bra loop
overflow: sec
bra done1
done: clc
inx ; drop
inx
inx
inx
done1: pla
sta CARRY
pla
sta SCRATCH
bcs :+ ; leave stack intact if exception
jmp _swap1
: rts
.endproc
; 32-bit by 32-bit division
; assumes that the second stack entry is zero
; ( d n -- r q ) where d.hi is zero e.g. ( n1 0 n2 -- r q )
; d.hi = stack(4,6) = 0, d.low = n1 = stack(8,10), n2 = stack(0,2)
.proc _udivmod32
lda #32
sta XR
l1: asl STACKBASE+8,x ; shift high bit of n1 into r
rol STACKBASE+10,x ; clearing the low bit for q
rol STACKBASE+4,x ; r.lo
rol STACKBASE+6,x ; r.hi
lda STACKBASE+4,x ; r.lo
sec ; trial subraction
sbc STACKBASE+0,x ; n2.lo
tay ; save low word
lda STACKBASE+6,x ; r.hi
sbc STACKBASE+2,x ; n2.hi
bcc l2 ; subtraction succeeded?
sta STACKBASE+6,x ; r.hi yes, save result
sty STACKBASE+4,x ; r.lo
inc STACKBASE+8,x ; n1.lo and record a 1 in the quotient
l2: dec XR ; next bit
bne l1
inx ; kill of top stack item
inx
inx
inx
clc ; this *never* overflows
jmp _swap1
.endproc
; ( d n -- ud u )
.proc _dnabs
lda STACKBASE+2,x ; take absolute value of n1
bpl :+
jsr _negate
: lda STACKBASE+6,x ; take absolute value of d
bpl :+
dtneg: inx
inx
inx
inx
jsr _dnegate
dex
dex
dex
dex
: rts
.endproc
_dtucknegate = _dnabs::dtneg
.proc _smdivrem
lda STACKBASE+6,x ; save dividend sign in MSW of high cell of d
pha
eor STACKBASE+2,x ; compute result sign and save
pha
jsr _dnabs ; take absolute value of arguments
jsr _umdivmod
bcs overflow ; overflow
pla ; see if we should negate quotient
bpl :+
jsr _negate ; make it negative
: pla ; get dividend sign
bpl :+
tneg: inx ; negate remainder if it should be negative
inx
inx
inx
jsr _negate
dex
dex
dex
dex
: clc
rts
overflow: pla ; carry is set, pla does not affect it
pla
rts
.endproc
_tucknegate = _smdivrem::tneg
.proc _fmdivmod
stz WR
lda STACKBASE+2,x
bpl :+
dec WR
jsr _dnabs
: lda STACKBASE+6,x
bpl :+
lda STACKBASE+0,x
clc
adc STACKBASE+4,x
sta STACKBASE+4,x
lda STACKBASE+2,x
adc STACKBASE+6,x
sta STACKBASE+6,x
: jsr _umdivmod
bcs :+
bit WR
bpl :+
jsr _tucknegate ; clears carry
: rts
.endproc
; adapted from Lee Davidson routine
; ( u1 -- u1 u2 ) u1 = closest integer <= square root, u2 = remainder
; number popped into WR,WR+2
; remainder on stack, offsets 0,2
; root on stack, offsets 4,6
; temp in YR
; counter in XR
.proc _sqroot
jsr _peekwr ; get number into WR
jsr _stackdecr ; make room for remainder
lda #16 ; pairs of bits
sta XR ; counter
lda #$0000
sta STACKBASE+0,x ; init remainder
sta STACKBASE+2,x
sta STACKBASE+4,x ; init root
sta STACKBASE+6,x
lp: asl STACKBASE+4,x ; root = root * 2
asl WR ; now shift 2 bits of number into remainder
rol WR+2
rol STACKBASE+0,x
rol STACKBASE+2,x
asl WR
rol WR+2
rol STACKBASE+0,x
rol STACKBASE+2,x
lda STACKBASE+4,x ; copy root into temp
sta YR
lda STACKBASE+6,x ; (a bit shorter than immediate load)
sta YR+2
sec ; +1
rol YR ; temp = temp * 2 + 1
rol YR+2
lda STACKBASE+2,x ; compare remainder with partial
cmp YR+2
bcc next ; skip sub if remainder smaller
bne subtr ; but do it if equal
lda STACKBASE+0,x
cmp YR
bcc next ; same deal
subtr: lda STACKBASE+0,x ; subtract partial from remainder
sbc YR
sta STACKBASE+0,x
lda STACKBASE+2,X
sbc YR+2
sta STACKBASE+2,x
inc STACKBASE+4,x ; no need to increment high word, always zero
next: dec XR
bne lp
rts
.endproc

626
asm/memmgr.s Normal file
View File

@ -0,0 +1,626 @@
; Memory allocation library
; Structure is a linked list beginning at HIMEM and ending at MEM_TOP
; when HIMEM=MEM_TOP, nothing is allocated
; where each entry in the list is <next(4)><flag+chk(2)><space>
; flag+chk is a 16-bit item whose top bit is 1 for in-use, 0 if free
; at some point, the remainder of the word are the low bits of the address of this
; block header in order to serve as a check for heap corruption
; Allocation is selectable from first-fit or best fit (see below) for extant free blocks
; Freeing the bottom block moves HIMEM up. Adjacent free blocks are combined.
; Tunables
SPLIT_THRESH = 8 ; if block can be split and remainder have this many
; bytes + 6 bytes header, split it
MIN_BRK = $400 ; minimum break between DHERE and HIMEM in pages
; Constants
HDR_SIZE = 6
; Allocate XR bytes, return carry set+pointer in AY if successful
; or carry clear+AY=0 if unsuccessful
; trashes WR (has copy of pointer to the block header) and YR
; This uses a first-fit algorithm. If the selected block has at bytes
; remaining after the allocation, the block will be split with the remaining
; space (less 4 bytes) put into the newly following block
.proc _alloc
jsr _chk_himem
bcs grow
jsr _find_free
bcs grow
; reuse, y = 4, A = existing flag word
ora #$8000
sta [WR],y
jsr _split ; split block if possible
bra _rtn_ptr
grow: jsr _grow_heap
bcs :+
ldy #$0004
lda #$8000
sta [WR],y
bra _rtn_ptr
: lda #$00
tay
clc
rts
.endproc
.proc _rtn_ptr
lda WR
clc
adc #.loword(HDR_SIZE)
tay
lda WR+2
clc
adc #.hiword(HDR_SIZE)
sec
rts
.endproc
.proc _split
jsr _blksize
lda YR ; YR = YR(size)-XR(requested size) = remaining space
sec
sbc XR
sta YR
lda YR+2
sbc XR+2
sta YR+2
lda YR ; now see if it's big enough to split
sec
sbc #.loword(SPLIT_THRESH+HDR_SIZE)
ldy YR+2
sbc #.hiword(SPLIT_THRESH+HDR_SIZE)
bmi done ; do not split, it's too small
lda WR ; set YR to be a pointer to the child block
clc ; YR = WR+XR+6
adc XR
sta YR
lda WR+2
adc XR+2
sta YR+2
lda YR ; (now account for header of parent block)
clc
adc #.loword(HDR_SIZE)
sta YR
lda YR+2
adc #.hiword(HDR_SIZE)
sta YR+2 ; ok now YR points to child block
ldy #$04 ; first mark child block free
lda #$0000 ; by zeroing its flags
sta [YR],y
dey
dey ; y = $02
lda [WR],y ; then copy high word next block pointer of parent
sta [YR],y ; into high word next block pointer of child
dey
dey ; y = $00
lda [WR],y ; and then do low word next block pointer
sta [YR],y ; copy to child
lda YR ; then set parent next block pointer to child
sta [WR],y ; low word
iny
iny ; y = $02
lda YR+2 ; high word
sta [WR],y
done: rts
.endproc
; Load SV_HIMEM into WR and compare to MEM_TOP
; return carry set if MEM_TOP >= SV_HIMEM
; carry clear, otherwise
.proc _chk_himem
ldy #SV_HIMEM
lda [SYSVARS],y
sta WR
iny
iny
lda [SYSVARS],y
sta WR+2
; fall-through
.endproc
; See if WR is at (or above) MEM_TOP
; Z and C reflect usual meanings
.proc _chktop
lda WR+2
cmp MEM_TOP+2
bne :+
lda WR
cmp MEM_TOP
: rts
.endproc
; Move WR to the next block, assuming WR points to an existing block
; return via comparison with MEM_TOP
.proc _nextblk
ldy #$00
lda [WR],y
pha
iny
iny
lda [WR],y
sta WR+2
pla
sta WR
bra _chktop
.endproc
; YR = [WR] - WR - 6
.proc _blksize
ldy #$00
lda [WR],y
sec
sbc WR
sta YR
iny
iny
lda [WR],y
sbc WR+2
sta YR+2
lda YR
sec
sbc #$0006
sta YR
lda YR+2
sbc #$0000
sta YR+2
rts
.endproc
.if 0 ; use first-fit if nonzero, best-fit if zero
; Find a free block of at least size XR
; if found, return with its address in WR and carry clear, YR is the block size, A
; is the contents of the flags word, and Y is 4
; otherwise carry set and WR should be equal to HIMEM
.proc _find_free
jsr _chk_himem
bcc lp
rts
next: jsr _nextblk
bcs done
lp: jsr _blksize
lda YR+2
cmp XR+2
bne :+
lda YR
cmp XR
: bcc next ; too big
ldy #$04 ; got one, is it free?
lda [WR],y
bmi next ; nope
clc
done: rts
.endproc
.else
; Find the best-fitting block of at least size XR
; if found, return with its address in WR and carry clear, YR is the block size, A
; is the contents of the flags word, and Y is 4
; otherwise carry set and WR should be equal to HIMEM
; trashes ZR, which holds the size of the best candidate so far
.proc _find_free
stz ZR ; zero out best fit size
stz ZR+2
jsr _chk_himem
bcc :+ ; if we have some heap, go see if anything free
rts ; otherwise just return with carry set
: pha ; make room on stack for "best" candidate
pha
bra lp ; enter loop
best: lda YR ; save block in WR as best block
sta ZR ; starting with size
lda YR+2
sta ZR+2
lda WR ; then with address
sta 1,s
lda WR+2
sta 3,s
next: jsr _nextblk
bcs done ; when we run out of blocks
lp: ldy #$04
lda [WR],y ; is it free?
bmi next ; nope, move on
jsr _blksize
lda YR+2
cmp XR+2
bne :+
lda YR
cmp XR
: bcc next ; too big
lda ZR ; do we have a best candidate so far?
ora ZR+2
beq best ; no, make this one the best
lda ZR+2 ; yes, see if this one is better
cmp YR+2
bne :+
lda ZR
cmp YR
: bcs best ; save as best (prefer higher blocks if =)
bra next ; otherwise go to next block
done: lda ZR
ora ZR+2
beq none
lda ZR
sta YR
lda ZR+2
sta YR+2
pla
sta WR
pla
sta WR+2
ldy #$04
lda [WR],y
clc
rts
none: pla ; drop the block pointer
pla
sec
rts
.endproc
.endif
; YR = WR-XR
.proc _wr_minus_xr
lda WR
sec
sbc XR
sta YR
lda WR+2
sbc XR+2
sta YR+2
rts
.endproc
; Grow heap to store at least XR bytes. Trashes WR and YR.
; return carry clear, HIMEM adjusted, and WR=new HIMEM if grow succeeded
; otherwise carry set and no changes to HIMEM
.proc _grow_heap
jsr _chk_himem
jsr _wr_minus_xr ; calculate bottom of reservation
lda YR ; then subtract header size
sec
sbc #.loword(HDR_SIZE)
sta YR
lda YR+2
sbc #.hiword(HDR_SIZE)
sta YR+2
lda DHERE ; now compare to DHERE+minimum break
clc
adc #.loword(MIN_BRK)
tay
lda DHERE+2
adc #.hiword(MIN_BRK)
cmp YR+2
bne :+
tya
cmp YR
: bcs done ; would put us in the break, byebye
lda YR ; move YR to WR
sta WR
lda YR+2
sta WR+2
ldy #$04 ; offset of flags
lda #$0000
sta [WR],y ; zero them (marked free)
ldy #SV_HIMEM+2 ; now get current HIMEM
lda [SYSVARS],y
pha ; save high byte on stack
dey
dey
lda [SYSVARS],y ; low byte...
ldy #$00
sta [WR],y ; use it to make link
iny
iny
pla
sta [WR],y
ldy #SV_HIMEM+2 ; and set HIMEM to WR
lda WR+2
sta [SYSVARS],y
dey
dey
lda WR
sta [SYSVARS],y
clc
done: rts
.endproc
; Free memory pointed to by WR (at first byte of data, not marker)
; Also trashes XR and YR
; returns carry set if things went fine
; clear if double-free or freeing top of heap
.proc _free
lda WR
sec
sbc #.loword(HDR_SIZE)
sta WR
lda WR+2
sbc #.hiword(HDR_SIZE)
sta WR+2
ldy #$04
lda [WR],y
bpl bad
and #$7FFF
sta [WR],y
jsr _collect
jsr _shrink_heap
sec
rts
bad: clc
rts
.endproc
; Collect adjacent free blocks into larger blocks
; uses WR,XR,YR
.proc _collect
jsr _chk_himem
bcs done
loop: ldy #$04
lda [WR],y
and #$8000
beq :+ ; this block is free, peek at the next block
next: jsr _nextblk ; otherwise, it is used, move on
bcc loop
done: rts
: dey
dey
lda [WR],y ; get next block address into YR
sta YR+2
dey
dey
lda [WR],y
sta YR
lda YR+2
cmp MEM_TOP+2 ; and see if it is MEM_TOP
bne :+
lda YR
cmp MEM_TOP
: bcs done ; if it is, we are done
ldy #$04 ; see if it is a free block
lda [YR],y
and #$8000
bne next ; if not free, move on
dey ; if free, eat it by copying its pointer to ours
dey
lda [YR],y
sta [WR],y
dey
dey
lda [YR],y
sta [WR],y
bra loop ; check this block *again* to roll up more
.endproc
; Shrink the heap by removing the first block, if it is free
.proc _shrink_heap
loop: jsr _chk_himem
bcs done
ldy #$04 ; see if free
lda [WR],y
and #$8000
bne done ; nope, it's used, we are done
dey
dey
lda [WR],y ; get pointer high word
pha ; save on stack
dey
dey
lda [WR],y ; get low word
ldy #SV_HIMEM ; and write it out to HIMEM making it the new HIMEM
sta [SYSVARS],y
iny
iny
pla
sta [SYSVARS],y
bra loop ; go check it again
done: rts
.endproc
.if 1 ; include fast memory move routines
; Memory move routines
; move XR bytes of memory from [WR] to [YR]
; Move appropriately based
.proc _memmove
lda WR
cmp YR
lda WR+2
sbc YR+2
; now carry is set if WR >= XR, move down in that case, otherwise move up
; fall-through
.endproc
; Move up if carry clear, down if carry set
.proc _memmove_c
php
lda XR ; first, pre-decrement XR
bne :+
dec XR+2
bpl :+
plp
rts ; nothing to move
: dec XR
plp
bcc _memmove_up
; fall-through if carry set
.endproc
; adapted from 6502org.wikidot.com
.proc _memmove_dn
fromh = WR+2
froml = WR
toh = YR+2
tol = YR
sizeh = XR+2
sizel = XR
md7 = ZR
phx
php
lda #$6B00 ; RTL
sta md7+2
lda #$0054 ; MVN
sta md7
sep #$21 ; 8-bit accumulator, set carry
.a8
lda fromh
sta md7+2
lda toh
sta md7+1
lda sizeh
eor #$80 ; set v if sizeh is zero, clear v otherwise
sbc #$01
rep #$30
.a16
.i16 ; already should be...
ldx froml
ldy tol
tya
cmp froml
bcc md3 ; if y < x then $FFFF-x < $FFFF-y
bra md4
.a8
md1: sta sizeh
eor #$80 ; set v if sizeh is zero, clear v otherwise
sbc #$01
cpx #$0000
bne md2 ; if x is not zero, then y must be
inc md7+2
rep #$20
.a16
tya
bne md4
sep #$20
.a8
md2: inc md7+1
rep #$20
.a16
md3: txa
md4: eor #$FFFF ; A xor $FFFF = $FFFF - a
bvc md5 ; branch if sizeh is nonzero
cmp sizel
bcc md6
lda sizel
md5: clc
md6: pha
phb
jsl f:_callzr
plb
pla
eor #$ffff ; a xor $ffff = $ffff - a = -1 - a
adc sizel
sta sizel ; sizel = sizel - 1 - a
sep #$20
.a8
lda sizeh ; update high byte of size
sbc #$00
bcs md1
rep #$30
.a16
.i16
plp
plx
rts
.endproc
.proc _memmove_up
fromh = WR+2
froml = WR
toh = YR+2
tol = YR
sizeh = XR+2
sizel = XR
mu7 = ZR
phx
php
lda #$6B00 ; RTL
sta mu7+2
lda #$0054 ; MVN
sta mu7
sep #$21 ; 8-bit accumulator, set carry
.a8
lda fromh
sta mu7+2
lda toh
sta mu7+1
lda sizeh
eor #$80 ; set v if sizeh is zero, clear v otherwise
sbc #$01
rep #$30
.a16
.i16
ldx froml
ldy tol
tya
cmp froml
bcs mu3
bra mu4
.a8
mu1: sta sizeh
eor #$80 ; set v if size is zero, clear v otherwise
sbc #$01
cpx #$FFFF
bne mu2 ; if x is not $FFFF, then y must be
dec mu7+2
rep #$20
.a16
tya
cpy #$FFFF
bne mu4
.a8
sep #$20
mu2: dec mu7+1
rep #$20
.a16
mu3: txa
mu4: bvc mu5 ; branch if sizeh is nonzero
cmp sizel
bcc mu6
lda sizel
mu5: clc
mu6: pha
phb
jsl f:_callzr
plb
pla
eor #$FFFF ; a xor $FFFF = $FFFF - a = -1 - a
adc sizel
sta sizel ; sizel = sizel - 1 - a
sep #$20
.a8
lda sizeh ; update high byte of size
sbc #$00
bcs mu1
rep #$30
.a16
.i16
plp
plx
rts
.endproc
.proc _callzr
sep #SHORT_A
.a8
pha ; ( -- x )
rep #SHORT_A
.a16
pha ; ( x -- x x x )
pha ; ( x x x -- x x x ah al )
sep #SHORT_A
.a8
lda #$00 ; ZR is in bank 0
sta 5,s ; ( x x x ah al -- 0 x x ah al )
rep #SHORT_A
.a16
tdc
dec a
clc
adc #.loword(ZR) ; calculate actual location of ZR
sta 3,s ; ( 0 x x ah al -- 0 zrh zrl ah al )
pla ; ( 0 zrh zrl ah al -- 0 zrh zrl )
rtl ; ( 0 zrh zrl -- )
.endproc
.endif

207
asm/system.s Normal file
View File

@ -0,0 +1,207 @@
; Main Forth system stuff. System variable declaration/initialization, system init,
; etc.
; System variable numbers
; Be sure to update initialization table, below
DEF_SYSVAR 0, SV_STATE ; STATE
DEF_SYSVAR 1, SV_BASE ; BASE
DEF_SYSVAR 2, SV_OLDHERE ; (old here for exception during definition)
DEF_SYSVAR 3, SV_CURRENT ; $CURRENT
DEF_SYSVAR 4, SV_NLINE ; #LINE
DEF_SYSVAR 5, SV_NOUT ; #OUT
DEF_SYSVAR 6, SV_dCIB ; $CIB
DEF_SYSVAR 7, SV_PIN ; >IN
DEF_SYSVAR 8, SV_NIN ; #IN
DEF_SYSVAR 9, SV_SPAN ; SPAN
DEF_SYSVAR 10, SV_dPPTR ; $PPTR
DEF_SYSVAR 11, SV_HIMEM ; for alloc-mem & free-mem
DEF_SYSVAR 12, SV_CSBUF ; current interpretation temp string buffer
DEF_SYSVAR 13, SV_SBUF0 ; interpretation temp string buffer 1 of 2
DEF_SYSVAR 14, SV_SBUF1 ; interpretation temp string buffer 2 of 2
DEF_SYSVAR 15, SV_SOURCEID ; Input source ID, 0 = console, -1 = EVALUATE
DEF_SYSVAR 16, SV_dTIB ; terminal input buffer
DEF_SYSVAR 17, SV_dCSDEPTH ; Control-flow stack depth for temporary definitions
DEF_SYSVAR 18, SV_dSAVEHERE ; saved HERE for temporary definitions
DEF_SYSVAR 19, SV_pTMPDEF ; pointer to memory allocated for temp def
DEF_SYSVAR 20, SV_FORTH_WL ; Forth wordlist
DEF_SYSVAR 21, SV_FORTH_WL_XT ; Pointer to the "FORTH" word
DEF_SYSVAR 22, SV_ENV_WL ; last environmental word
DEF_SYSVAR 23, SV_ENV_WL_XT ; pointer to "$ENV?" word
DEF_SYSVAR 24, SV_dORDER ; Pointer to search order list
DEF_SYSVAR 25, SV_dCURDEF ; $CURDEF pointer to current colon, noname, etc. def
.if include_fcode
DEF_SYSVAR 26, SV_FCODE_IP ; FCode IP
DEF_SYSVAR 27, SV_FCODE_END ; FCode end, if true FCode evaluator will stop
DEF_SYSVAR 28, SV_FCODE_SPREAD ; Current FCode spread
DEF_SYSVAR 29, SV_FCODE_OFFSET ; if true, offsets are 16 bits
DEF_SYSVAR 30, SV_FCODE_FETCH ; XT of FCode fetch routine, usually C@
DEF_SYSVAR 31, SV_FCODE_TABLES ; Pointer to FCode table pointers
DEF_SYSVAR 32, SV_FCODE_LAST ; Last FCode# in NEW-, NAMED-, or EXTERNAL-TOKEN
DEF_SYSVAR 33, SV_FCODE_DEBUG ; whether FCode debugging is enabled
.endif
.proc _jtab
init: jmp __initialize
ui: jmp __ui
.endproc
.export _Forth_jmptab = _jtab
.export _Forth_initialize = _jtab::init
.export _Forth_ui = _jtab::ui
; Table of initialization values for system variables
.proc SVARINIT
.dword 0 ; STATE 0
.dword 16 ; BASE 4
.dword 0 ; OLDHERE 8 for exception during definition
.dword 0 ; $CURRENT - WID of the compiler word list
.dword 0 ; #LINE 16
.dword 0 ; #OUT 20
.dword 0 ; $CIB 24
.dword 0 ; >IN 28
.dword 0 ; #IN 32
.dword 0 ; SPAN 36
.dword 0 ; $PPTR 40
.dword 0 ; HIMEM 44 - for alloc-mem and free-mem
.dword 0 ; CSBUF
.dword 0 ; SBUF0
.dword 0 ; SBUF1
.dword 0 ; SOURCEID
.dword 0 ; $TIB
.dword 0 ; $CSDEPTH
.dword 0 ; $SAVEHERE
.dword 0 ; $>TMPDEF
.dword LAST_forth ; Forth wordlist
.dword FORTH ; "FORTH" word xt
.dword LAST_env ; environmental query wordlist
.dword ENVIRONMENTQ ; "ENVIRONMENT?" xt
.dword 0 ; search order pointer, if zero always uses Forth wordlist
.dword 0 ; $CURDEF
.if include_fcode
.dword 0 ; $FCODE-IP
.dword 0 ; $FCODE-END
.dword 1 ; $FCODE-SPREAD
.dword 0 ; $FCODE-OFFSET
.dword dRBFETCH ; $FCODE-FETCH
FCROM fc_romtab ; $FCODE-TABLES
.dword $7FF ; $FCODE-LAST last FCode# in NEW-, NAMED-, or EXTERNAL-TOKEN
.dword 0 ; FCODE-DEBUG?
.endif
.endproc
SYSVAR_INIT SVARINIT ; check size of initialize values
.proc _call_sysif
sta ZR+2 ; save function #
stx ZR ; calculate stack depth
lda STK_TOP
sec
sbc ZR
lsr
lsr
tay
lda SYSIF+2
sep #SHORT_A
pha
rep #SHORT_A
lda SYSIF
pha
lda ZR+2 ; get function #
rtl
.endproc
; Enter with direct page register pointing to direct page reserved for the system
; with enough space for the variables in equates.inc
; and the following parameters on the '816 stack:
; system memory high (32-bit)
; system memory low (32-bit)
; stack top (16-bit) - this the bank 0 address just after first usable cell, relative to D
; stack bottom (16-bit) - this is the bank 0 address of the last usable cell, relative to D
; return stack top (16-bit) - return stack top, to be used by all routines
; except initialize
; system interface function (32-bit) - vector to basic I/O, etc.
; each stack must have at least 64 32-bit cells, a total of 256+ bytes each.
.proc __initialize
; set up direct page
pla ; first, save caller address
sta WR
sep #SHORT_A
pla
sta WR+2
rep #SHORT_A
pla ; get address of system interface function
sta SYSIF
pla
sta SYSIF+2
lda SYSIF ; we are going call it via RTL, so decrement
bne :+
dec SYSIF+2
: dec SYSIF
pla
sta RSTK_TOP
sta RSTK_SAVE ; really a placeholder for completeness
pla
sta STK_BTM
pla
sta STK_TOP
pla
sta MEM_BTM
sta SYSVARS ; sysvars at memory bottom
pla
sta MEM_BTM+2
sta SYSVARS+2
pla
sta MEM_TOP
pla
sta MEM_TOP+2
sep #SHORT_A ; restore caller address
lda WR+2
pha
rep #SHORT_A
lda WR
pha
; okay, direct page is set up from stack, do the rest of it
tsc ; switch to Forth return stack
sta SYS_RSTK
lda RSTK_TOP
tcs
phb ; save data bank for caller
phk
plb ; make sure we can move SYSVARS & OF816
lda SYSVARS
clc
adc #.sizeof(SVARINIT)
sta DHERE
lda SYSVARS+2
adc #$00
sta DHERE+2
ldy #0
: lda SVARINIT,y
sta [SYSVARS],y
iny
iny
cpy #.sizeof(SVARINIT)
bcc :-
stz CATCHFLAG
; Now do forth-based initialization
ldx STK_TOP
lda #SI_PRE_INIT
jsl _call_sysif ; hope it works, because we don't check!
ENTER
.dword ddSYSINIT
CODE
; Remaining platform init platform if needed
lda #SI_POST_INIT
jsl _call_sysif ; carry flag propagates to RTL
plb ; restore caller data bank
lda SYS_RSTK ; and stack
tcs
rtl
.endproc
.proc __ui
tsc
sta SYS_RSTK
ldx STK_TOP
jmp __doquit
.endproc

11
build.sh Executable file
View File

@ -0,0 +1,11 @@
#!/bin/bash
cd `dirname ${0}`
PLATFORM=""
if [ -n "${1}" -a -d "platforms/${1}" ]; then
PLATFORM="${1}"
fi
export PLATFORM
echo ".define PLATFORM \"${PLATFORM}\"" > platform.inc
set -e -x
ca65 -I inc forth.s -l forth.lst

84
config.inc Normal file
View File

@ -0,0 +1,84 @@
PLATFORM_INCLUDE "platform-config.inc"
; *** options ***
; Set this to a nonzero value if any code will run out of bank 0. If not set, then
; numeric literals <= $0000FFFF will use the "fast literal" mode, getting on the
; stack faster and using less memory. This should be set in the platform-specific
; config, and will only be set here if the platform config does not set it.
.if .defined(platform_fast_lits)
.out "platform_fast_lits set by platform config or cmdline"
.define no_fast_lits 0
.else
.define no_fast_lits 1