6502
/
of816
mirror of https://github.com/mgcaret/of816.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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
View File

File diff suppressed because it is too large Load Diff

6914
asm/forth-dictionary.s Normal file
View File

File diff suppressed because it is too large Load Diff

1078
asm/interpreter.s Normal file
View 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
.endif
; Set this to the size of the terminal input buffer. This will be dynamically allocated
; when the system starts. If command line history is enabled, several of these may be
; allocated at any given time. IEEE 1275 requires that it be 128 chars.
.define tib_size 128
; Set this to the number of bytes in the PAD. This is not required by IEEE 1275 and can
; be turned off with 0, saving a few bytes. ANSI X3J14-1994 requires at least 84 chars
; (bytes in our case) in the pad if it is present
.define pad_size $100
; Set this to the byte size of the WORD buffer. IEEE 1275 requires it to be (>=) 80.
; this buffer is shared with the pictured numeric output, which IEEE 1275 requires to
; be able to hold (>=) 66 characters.
.define word_buf_size 80
; Set this to a nonzero value to include FCode features (see IEEE 1275). This will
; cause the system size to increase by ~6K and also increase memory usage.
; The FCode evaluator supports most of the non-Device Tree FCode numbers, which can be
; added later via FCode or source in order to build an Open Firmware implementation on
; top of OF816.
.define include_fcode 1
; Set this to the number of word lists that may be in the search order. This number
; is required by ANSI X3J14-1994 to be 8 or greater if search order words are implemented.
; If this is set to 0, search order words are not included and about 1K is saved from
; the system size.
.define max_search_order 8
; IEEE 1275 specifies that certain words where interpretation semantics are not defined
; by ANSI X3J14-1994 must trigger a temporary definition outside of data space in order
; to provide interpretation semantics equivalent to what occurs in a compiled word.
; (e.g. '10 0 do i . loop' works outside of a definition)
; set this to the number of bytes allowed for such a temporary definition (512 =~ 128
; cells). The memory used for a temporary definition is allocated from the heap, and is
; *not* bounds-checked during creation of the temporary definition.
.define max_tempdef 512
; SEE is a large complicated word. Omitting it saves 500 bytes.
.define include_see 1
; quotations are non-standard in ANS Forth and IEEE 1275, but may be useful
.define enable_quotations 1
; IEEE 1275 declines to identify what ENVIRONMENT? should return. ANS Forth gives
; specifics, but Forth 2012 deprecates detecting wordlists through environmental queries
; set this to 0 to include no environmental queries (ENVIRONMENT? always returns false)
; set this to 1 to include everything but the word list entries
; set this to 2 to include all of them
; note that the routines to access the environmental queries dictionary are not omitted,
; even when env_query_level is zero. As long as max_search_order is nonzero it is
; possible to add items to the environmental query dictionary
.define env_query_level 0
; UNALIGNED-[LW][!@] words are specified by IEEE 1275 for the user interface only (not
; FCode). In general these are redundant on the '816 because all accesses are unaligned,
; and in fact are defined as aliases to the normal versions of these.
; set this to 0 to exclude them, saving a few bytes.
.define unaligned_words 0
; *** debug options ***
.define trace 0 ; requires emulator cooperation via WDM instruction
.define print_dict 0 ; output word addresses and XTs during assembly
.if trace
.define no_headerless 1
.else
.define no_headerless 0 ; set to 1 to compile headers for all words for debugging
.endif

228
docs/getting_started.md Normal file
View File

@ -0,0 +1,228 @@
# Getting Started
## References
[IEEE 1275-1994](http://www.openbios.org/data/docs/of1275.pdf)
[ANS Forth X3.215-1994](http://lars.nocrew.org/dpans/dpans.htm)
## Basics
OF816 implements ANS Forth as described by IEEE 1275-1994, but lacking the
packages system and Device Tree features. It is advisable to read the above
documents as well as a Forth tutorial.
### System Information
OF816 is a portable Forth system. The bulk of the system is self-contained and
may be linked by itself and placed in the ROM or RAM of a target system
(restriction: code segments must not cross bank boundaries). The host system
can then configure and instantiate the interpreter via a jump table. Creating
a specific port allows the easy inclusion of platform-specific words and
routines, and allows leveraging of Forth components to implement the system
interface.
The source code is logically broken down into config, macros, equates, the two
dictionaries, routines pertaining to interpretation/run-time, routines
pertaining to compilation, math library, memory management library, and FCode
evaluation.
FCode may be created with the
[OpenBIOS FCode suite](https://www.openfirmware.info/FCODE_suite). Get the
FCode into ROM or RAM and use ``<addr> 1 byte-load`` to evaluate it. See the
W65C816SXB for example FCode to useful things, such as scan for and load
additonal FCode.
### Included Ports
* [W65C816SXB](https://wdc65xx.com/boards/w65c816sxb-engineering-development-system/).
* Apple IIgs.
See the README files in each port's directory under /platforms for build &
installation instructions.
## Configuration and Build
The system may be configured by changing values in ``config.inc``. Each option
is described in that file. Note that changing the options may affect the
conformance statments that appear in this document, and/or the supported
features of the resulting system.
OF816 is assembled and linked with the ``ca65`` assembler and ``ld65`` linker
from the [cc65 toolchain](https://github.com/cc65/cc65). To build a basic
cc65 object file with the basic system (no platform-specific code), execute
build.sh in the project root directory.
Each platform port has their own method to build an image, see the directories
for each platform under ``platforms/``.
## Porting/System Implementation
See porting.md for instructions on how to port OF816 to your platform including
implementing the system interface.
## Conformance
### ANS Conformance
* Providing the Core word set.
* Providing ``.(``, ``.R``, ``0<>``, ``0>``, ``2>R``, ``2R@``, ``:NONAME``,
``<>``, ``?DO``, ``AGAIN``, ``CASE``, ``COMPILE,``, ``ENDCASE``, ``ENDOF``,
``ERASE``, ``EXPECT``, ``FALSE``, ``HEX``, ``NIP``, ``PAD``, ``PARSE``,
``PICK``, ``REFILL``, ``RESTORE-INPUT``, ``ROLL``, ``SAVE-INPUT``,
``SOURCE-ID``, ``SPAN``, ``TO``, ``TRUE``, ``TUCK``, ``U.R``, ``U>``,
``UNUSED``, ``VALUE``, ``WITHIN``, ``[COMPILE]``, and ``\`` from the Core
Extensions word set.
* Providing ``2CONSTANT``, ``D+``, ``D-``, ``D.R``, ``D>S``, ``DABS``,
``DNEGATE``, and ``2ROT`` from thge Double-Number word set.
* Providing the Exception word set.
* Providing the Facility word set.
* Providing Programming-Tools word set.
* Providing ``;CODE``, ``AHEAD``, ``BYE``, ``CODE``, ``FORGET``, and ``STATE``
from the Programming-Tools Extensions word set.
* Providing the Search Order word set.
* Providing ``-TRAILING``, ``BLANK``, ``CMOVE``, ``CMOVE>``, ``COMPARE``,
``SEARCH``, and ``SLITERAL`` from the String word set.
#### Implementation-defined Options
See IEEE 1275-1994 section 2.4.3 "ANS Forth compatibility" for
implementation-defined options that are defined by that standard, with the
following exeptions/differences:
* Method of selection of console input and output device: Always defined by
the system interface.
* Packed strings are limited to 255 bytes as in Open Firmware. However,
counted strings may be larger and in practice most words that operate with
strings will accept strings of at least 65535 bytes.
* The maximum string length for ``ENVIRONMENT?`` queries is 128.
* The size of the console's input buffer is normally 128 but may be changed at
assembly time.
Items from IEEE 1275-1994 that remain implementation-defined are defined in
OF816 as follows:
* Aligned address requirements: None. The 65C816 CPU does not have alignment
restrictions. Words that influence alignment or are affected by alignment
are no-ops or equivalent to their unaligned counterparts.
* Behavior of ``EMIT`` for non-graphic values: The character is passed to the
system interface to be handled in a manner defined by that interface.
* Control-flow stack: The parameter stack.
* Console input and output device: Defined by the system interface functions.
* Exception abort sequence: If ``CATCH`` is not used, an error message is
displayed and control is returned to the user via ``QUIT``.
* Input line terminator: CR (0x0D).
* Methods of dictionary compilation: appended to the data space afer the
previous definition.
* Methods of memory space management: There is one data space, it can be
allocated by traditional methods (``ALLOT``, etc.) from the bottom, and can
be allocated by ``ALLOC-MEM`` and freed by ``FREE-MEM`` from the top.
* Minimum search order: The minimum search order contains forth-wordlist. In
the event the search order is empty, the current compiler word list is
searched.
* Size of the scratch area who is addressed in ``PAD``: ``PAD`` is optional,
size set at assembly time. Dynamically moves as the dictionary grows.
* Non-standard words using ``PAD``: none.
* The current definition can be found after ``DOES>``
* Source and format of display by ``SEE``: list of names and addresses.
Output not guaranteed to be correct/complete for built-in words.
Other notes:
* ``WORD`` shares its buffer with the pictured numeric output. The normal
size meets IEEE 1275-1994, but it may be changed at assembly time.
### Forth Interpreter IEEE 1275-1994 Conformance
The command mode of the interpreter currently *does not* implement any of the
editing features described by IEEE 1725-1994.
The following parts of IEEE 1275-1994 are implemented in the main interpreter
("user interface") of OF816:
* The entirety of section 7.3 "Forth command group."
* From section 7.4: ``RESET-ALL``.
* From section 7.5: ``SHOWSTACK``, ``NOSHOWSTACK``, ``WORDS``, ``SEE``,
``(SEE)``.
The following are not implemented:
* The entirety of section 7.4 "Administration command group."
* Most of section 7.5 except those noted above.
* The entirety of section 7.6.
* The entirety of section 7.7.
### FCode Evaluator IEEE 1275-1994 Conformance
#### Supported FCodes
When FCode support is included, the following FCodes **are** available.
Generally, any caveats mentioned for words of the Forth interpreter apply to the
associated FCodes.
* All the FCodes from subsections 5.3.2.1, 5.3.2.2, 5.3.3.2, 5.3.3.3, 5.3.3.4.
* All the FCodes from subsection 5.3.3.1 *except* 0xC0 ``INSTANCE``.
* All the FCodes from subsection 5.3.3.3.
* 0x240 ``LEFT-PARSE-STRING`` and 0x11B ``PARSE-2INT`` from section 5.3.4.
* All the FCodes from subsections 5.3.7.1 and 5.3.7.2.
* All the FCodes from subsection 5.3.7.6 *except* 0x11F ``NEW-DEVICE``, 0x127
``FINISH-DEVICE``, and 0x23F ``SET-ARGS``.
#### Unimplemented FCodes
The following FCodes **are not** available:
* All the fcodes from section 5.3.4 ("Package access") *except* 0x240
``LEFT-PARSE-STRING`` and 0x11B ``PARSE-2INT``.
* All the fcodes from section 5.3.5 ("Property management").
* All the FCodes from section 5.3.6 ("Display device management").
* All the FCodes from subsections 5.3.7.3, 5.3.7.4, and 5.3.7.5.
* 0x11F ``NEW-DEVICE``, 0x127 ``FINISH-DEVICE``, and 0x23F ``SET-ARGS`` from
subsection 5.3.7.6.
## Implementation-specific Words
The following implementation-specific words are present:
* ``$ENV?-WL`` ( -- wid ) return the wordlist for environmental queries.
* ``CICOMP`` ( addr1 addr2 u1 -- n1 ) case-insensitive version of ``COMP``.
* ``CONTEXT`` ( -- wid ) return the wordlist at the top of the search order.
* ``SEAL`` ( -- ) set the search order to contain only the current
``CONTEXT``.
* ``$DIRECT`` ( -- a-addr ) provide the address of the 65C816 Direct Page used
by Forth.
* ``$FORGET`` ( xt -- ) attempt to forget the word at xt and subsequent
definitions.
* ``VOCABULARY`` ( "name"< > -- ) create a named vocabulary.
* ``$EMPTY-WL`` ( -- WID ) create a new completely empty wordlist without even
the root words.
* ``:TEMP`` ( ... -- ... ) start a temporary definition, execute it when ; is
executed. Exposes the underlying implementation for interpretation
semantics of various control-flow words such as ``DO``...``LOOP`` and
others.
* ``%DEFER``, ``%VARIABLE``, ``%BUFFER``, ``%VALUE`` (only when FCode is
enabled) ( -- ) compile the execution behavior of these types of words after
FCode executes a token-creating word.
* ``$2VALUE`` ( n1 n2 c-addr u -- ) create a ``2VALUE``.
* ``$VALUE`` ( n c-addr u -- ) create a ``VALUE``
* ``$CREATE`` ( c-addr u -- ) make a create word.
* ``ACONCAT`` ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 ) assuming the stack
contains two strings held in memory allocated by ``ALLOC-MEM``, concatenate
them into a new string and ``FREE-MEM`` the originals.
* ``A"`` ( "string"<"> -- c-addr u ) parse string and place it in memory
allocated by ``ALLOC-MEM``.
* ``>NAME`` ( xt -- c-addr u ) find name or text representation of xt. May
use the word/pictured numeric output buffer.
* ``>LINK`` ( xt -- c-addr ) find link field of xt, 0 if none (noname).
* ``$BYTE-EXEC`` ( addr xt -- ) (only when FCode is enabled) evaluate FCode at
addr, fetching with xt. Do not save or restore evaluator state
(cf. ``BYTE-LOAD``).
* ``SQRTREM`` ( u1 -- u2 u3 ) calculate closest integer root less than or
equal to the actual square root of u1, leaving u3 as the remainder.
* ``$TMPSTR`` ( c-addr1 u1 -- c-addr2 u2 ) copy string into the next temporary
string buffer and return the copy. This exposes the underlying
implementation of interpretation semantics for ``S"`` and ``"``.
* ``$SYSIF`` ( ... callnum -- ... ) make calls to the system-specific
interfacing.
* ``DEBUG-MEM`` ( -- ) display memory managed by ``ALLOC-MEM``/``FREE-MEM``.
* ``BSX`` ( byte -- n ) byte sign-extend
* ``WSX`` ( word -- n ) word sign-extend
* ``$MEMTOP`` ( -- addr ) variable holding top of memory (byte immediately
after data space)
* ``[:`` and ``;]`` [quotations](http://www.forth200x.org/quotations.txt).
* Others I probably forgot.
Note that individual platform ports may provide their own additional words.

262
docs/internals.md Normal file
View File

@ -0,0 +1,262 @@
# OF816 Internals
## System Description
OF816 is a portable direct-threaded ANS Forth system for the WDC 65C816
processor.
The system features 32-bit code and data cells, and implements a 32-bit virtual
address space (truncated to 24-bit physical addresses).
## Code Organization
The main file ``forth.s`` is the sole source file that is directly given to the
assembler. This file brings in all the other source via ca65's ``.include``
directive.
### Include Files
#### ``config.inc``
In the top level directory, ``config.inc`` contains configuration
options for the build in the form of ca65 ``.define`` directives.
#### ``platform.inc``
Additionally, when ``build.sh`` is executed it creates a ``platform.inc`` file
that sets the platform to build. ``PLATFORM`` is defined as a blank value if no
platform is given. Otherwise, if a platform is passed to ``build.sh`` and a
directory in ``platforms/`` exists that matches, ``PLATFORM`` will be set to
that value.
#### ``inc/macros.inc``
Macros for the system are in this and include dictionary macros,
shortcut macros for common Forth operations (e.g. ``NEXT``), and other items.
This also contains some system-specific equates and constants not included
in ``inc/equates.inc``.
#### ``inc/equates.inc``
Contains general equates for the system, including direct page, system interface
function codes, compiler constants, characters, etc.
### Source Code
The non-platform source code is in ``asm/`` and contains the following files.
#### ``asm/compiler.s``
Contains support routines related to the the Forth compiler and appending
to data space in general.
#### ``asm/env-dictionary.s``
Contains the environmental queries dictionary.
#### ``asm/fcode.s``
Contains most of the FCode support code, less a few items that end up in the
Forth dictionary. This code is assembled in the "FCode" segment.
#### ``asm/forth-dictionary.s``
Contains all of the Forth dictionary, including headerless helper words.
#### ``asm/interpreter.s``
Contains the inner interpreter and supporting code.
#### ``asm/mathlib.s``
Contains routines for basic math operations that need to be used by native
code, as well as the integer multiplication and division routines.
#### ``asm/memmgr.s``
Contains memory management routines, including the heap allocator and fast
memory move routines.
#### ``asm/system.s``
Contains the system entry points, initial system variables, and system
interfacing routines.
### Platform Files
Each platform is expected to provide at least the following files when a build
is created for a specific platform. Other files may be included by these files.
A platform will typically also have code that instantiates the interpreter and
is linked with the built ``forth.o`` as well as a linker configuration file.
#### ``platform-config.inc``
If the platform allows for additional configuration defines, these should be
placed here.
#### ``platform-lib.s``
This file should contain the necessary platform-specific code and will often
contain all system interfacing that occurs when the system is instantiated.
#### ``platform-words.s``
This file should contain any additonal entries that are to appear in the Forth
dictionary.
## Forth Interpreter
For reference on the basic construction and operation of a Forth interpreter,
see _Threaded Interpretive Languages_ by R.G. Loeligern (Byte, 1981).
### System Registers
The Forth system interpreter registers are implemented as follows:
**I** (IP): The Instruction register is implemented on the direct page as the
32-bit pointer **IP**. The IP always points to the byte immediately before the
next Forth code cell.
**WA/CA**: Being a direct-threaded interpreter, word address and code address
are effectively the same. The WA/CA register in this system is ephemeral
in that the next code address to execute is typically held in the 65816 A+Y
registers and then the lower 24-bits pushed onto the stack and finally executed
via RTL.
**RS**: The Forth return stack register is the 65816 stack register.
**SP**: The Forth paramter stack register is the 65816 X register.
**WR/XR/YR/ZR**: Direct-page working registers for use by primitives.
### Main Inner Interpreter Routines
The inner interpreter consists of the routines in ``interpreter.s`` that
explicitly implement the inner interpreter as well as all routines that support
execution of Forth code.
The main portion of the inner interpreter consists of the following routines.
**``_enter``**: enter (or nest) the Forth interpreter.
This routine swaps the 24-bit return address on the 65816 return stack for the
32-bit Forth IP and begins interpreting Forth code cells.
The net effect is that when entered via JSL, the old IP is saved, and the next
Forth code cell to be executed is immediately after the JSL instruction.
Shortcut macro: ``ENTER``.
**``_next``**: fetch and execute the next Forth code cell. This is the usual
method to exit Forth primitives.
Shortcut macros: ``NEXT`` (same-segment/bank), ``LNEXT`` (different segment/
bank).
**``__next::run``**: Execute Forth code beginning with the Forth XT in the
65816 AY registers.
Shortcut macros: ``RUN``
The Forth word ``EXECUTE`` is implemented (in pseudo-code) as: POP AY; RUN.
**``_exit_next``**: Restore previous IP from return stack and execute the next
code cell. This is the usual method to exit Forth secondaries.
Shortcut macro: ``EXIT``.
**``_exit_code``**: Swap the 32-bit previous IP on the return stack with the
24 low bits of the Forth IP and resume native code execution via RTL.
The net effect is to resume native code execution after this word is executed
as a Forth XT.
Shortcut macro: ``CODE``.
Multiple ``ENTER``s and ``CODE``s may be used to freely mix Forth and native
code.
## Dictionary
### Dictionary Format
The dictionary format is as follows:
```
+---------+--------------------------------------------------------|
| Size | Use |
+---------+--------------------------------------------------------|
| 4 bytes | Link to previous word (0 if end of dictionary) |
| 1 byte | Name length + $80 (high bit always set) if $80, noname |
| n bytes | Name |
| 1 byte | Flags |
| m bytes | Code |
+---------+--------------------------------------------------------|
Flags bits:
+-----+-------------------------------+
| 7 | Immediate |
| 6 | Compile-only |
| 5 | Protected (not FORGETtable) |
| 4 | Trigger temporary definition |
| 3 | Smudged (not found in search) |
| 2-0 | unused |
+-----+-------------------------------+
```
### Word Lists/WIDs
WIDs are pointers to wordlist objects.
A wordlist object consists of two cells. The first cell points to the head
(most recently-defined definition) of the wordlist. The second cell is either
0 or contains an XT, the name of which is used for the name of the wordlist
for display purposes (e.g. when ``ORDER`` is executed). Typically the XT's
execution semantics are to place the given wordlist at the top of the search
order.
### Dictionary Macros
``macros.inc`` provides macros for creating dictionaries/definitions. They are
not all documented here, but a brief overview is:
A dictionary is begun with ``dstart <name>`` and finished with ``dend``.
In between are one or more definitioons created with ``dword`` or ``hword``
and ``eword``. ``dword <label>,"<NAME>"[,<flags>]`` creates a definition with a
header and ``hword <label>,"<NAME>"[,<flags>]`` creates a headerless (noname)
definition. Flags are generally meaningless in a headerless definition.
The label is created at the execution token address of the definition, which is
always the flags byte, which is one byte less than the actual executable code.
The name must always be in capital letters, however dictionary searches are
case-insensitive.
### Primitive Definitions
A typical primitive is defined as follows:
```
dword my_word,"MY-WORD"
<native code>
NEXT
eword
```
### Secondary Definitions
A secondary that called the above primitive would be defined as:
```
dword my_word_secondary,"MY-WORD-SECONDARY"
ENTER
.dword my_word
EXIT
eword
```
Here, ``ENTER`` nests the interpreter and ``EXIT`` un-nests the interpreter
and executes NEXT.

167
docs/porting.md Normal file
View File

@ -0,0 +1,167 @@
# Porting OF816
OF816's base system is usable either as a library of sorts or as the basis of a
port to a particular platform. The main build script in the root directory,
when given no platform argument, will create a forth.o in the same location that
may be linked at any address with ld65.
A specific platform may be supported by creating a platforms/<name> directory
and populating it. The best way to see how to do this is to examine the
existing ports.
## Linker/Segments
When creating a ld65 configuration file, the following segments must be
configured/placed:
* ZEROPAGE - a bss segment for the direct page. The system will initialize
this.
* FSystem - The main system. ROMable.
* FCode - Place as an optional segment. May be located in a separate bank.
ROMable.
Segments may *not* cross bank boundaries.
## Using as a "Library"
To use OF816 as a library, set your options in config.inc and run build.sh.
The resulting Forth.o may be linked as per above and placed in RAM or ROM.
Currently the beginning of the FSystem segment has a jump table with two entries
that may be called using JSL:
### FSystem+$0: ``_Forth_initialize``
This call initializes the Forth interpreter. This should be called with the
direct page register set to the address you wish the Forth interpreter to use.
The other registers need not contain any specific values.
The 65C816 stack should contain the following items when ``_Forth_initialize``
is called:
```
+--------- Top of Stack ----------+
| System Memory High | 32-bit
| System Memory Low | 32-bit
| Stack Top | 16-bit
| Stack Bottom | 16-bit
| Return Stk Top | 16-bit
| System Interface Function | 32-bit
-------- Bottom of Stack ---------+
```
System Memory High and Low define the data space used by Forth. This space must
be contiguous and may cross bank boundaries. The Low address points to the
first usable byte in data space, and the High address points to the byte
immediately after the last usable byte in data space.
The Stack Top and Stack bottom define the addresses of the Forth parameter stack
*relative to the direct page*. The stack grows downward as the 65C816 does, but
the stack pointer (X register) points to the first entry of the Forth stack
(rather than the first unused byte). The Top is the address immediately after
the first usable cell. The Bottom value is the address of the last usable cell.
Note this reverse of sense with regard to how items on the stack are referred.
The Return Stack Top is the address in Bank 0 that has the highest usable
address of the return stack to be used by Forth. Calls to Forth will save the
return stack pointer upon entry and restore it on exit.
To meet the standards to which OF816 strives for and prevent ``ENVIRONMENT?``
from lying, the parameter stack and return stack must be at least 64 cells in
size (256 bytes).
The System Interface Function is described in its own section, below.
The system does not use any absolute addresses (though platform ports might),
so it is entirely possible to initialize more than one Forth in a system. An
external task manager could multitask these, in theory. Subsequent calls to an
initialized Forth require only that the direct page be correctly set.
### FSystem+$3: ``_Forth_ui``
This should be called with the direct page set to the Forth direct page used
when ``_Forth_initialize`` was called. This function enters the outer
interpreter (the user interface of Forth) and does not return until ``BYE``
is executed.
## Using as a Port
The system may be specifically ported to a platform. This has the advantage of
allowing platform-specific words to be defined as well as providing a means to
initialize other parts of the system prior to initializing the Forth system.
The best way to see how to do a platform port is to examine the Apple IIgs and
W65C816SXB ports included with OF816.
Ports must still define their System Interface Function and use the jump table
described above, but the code may use internals of the Forth system for ease of
implementation and compactness.
## The System Interface Function
When ``_Forth_initialize`` is called, one of the parameters passed to it is the
System Interface Function. This function is used to allow for extra
initialization of the system as well as provide console and other services.
The System Interface Function is always called with the following:
* Called via JSL.
* Processor in native mode with long registers.
* Direct page and return stack pointers are the Forth system values.
* A register: Function code (values described below). Function codes < $8000
are reserved to be defined by the Forth system. Function codes >= $8000
may be defined by the platform port.
* X register: Forth stack pointer (relative to direct page). The Forth stack
consists of 32-bit cells and grows downward.
* Y register: Current depth of Forth stack.
The System Interface Function must exit with the following:
* Return via RTL, with the processor mode, direct page, and return stack
intact.
* Have the expected Forth parameter stack effects.
* The A and Y registers contain the high and low words of a throw code or zero
if successful.
* Carry set if an error occurred (``THROW`` will be executed in most cases).
* Carry clear if no error occurred.
### System Interface Function Codes
#### $0000 - Pre Initialize Platform ( -- )
This is called immediately before the inner interpreter is entered for the first
time for initialization, so that last-minute platform initialization may occur.
This routine is not checked for errors.
#### $0001 - Post Initialize Platform ( -- )
This is called immediately after the inner interpreter exits from
initialization, so that additional platform-specific initialization may occur.
This routine is not checked for errors.
#### $0002 - Emit Character ( char -- )
This routine should emit a the given character to the console output device.
#### $0003 - Input Ready Query ( -- f )
Return with f true (all bits set, typically) if there is a character ready to
be read from the console input device.
#### $0004 - Input Character ( -- char )
Recieve char from the console device, waiting for it to arrive.
#### $0005 - FCode List Pointer ( -- address ) currently not used
When the feature is implemented and FCode support is built assembled into the
Forth system, this function should return the address of one or more cells
containing the addresses of tokenized FCode to evaluate at initialization time,
or zero if there are none. The list should end with zeros.
For now, this should simply return 0.
#### $0006 - Reset-All ( -- ) reboot the system as if the power had been cycled
When this call is made, it should reset the system as if the power had been
recycled. If this is not possible for the platform, it should return an
exception code.

72
fcode-modules/editor.fs Normal file
View File

@ -0,0 +1,72 @@
start1 decimal
." OF816 screen EDITOR by M.G. "
s" get-current vocabulary EDITOR also EDITOR definitions" evaluate
headers
\ necessary defers
defer $at-xy
s" at-xy" $find 0= if abort then to $at-xy
defer $page
s" page" $find 0= if abort then to $page
defer $-trailing
s" -trailing" $find 0= if abort then to $-trailing
\ other defers
external
defer $header \ to be used to display block #, etc.
' noop to $header
headers
\ set up variables
64 value $c/l
0 value $buf
\ adapted from miniEDIT in Bill Meunch post to comp.lang.forth 1/24/2010
: head ( -- )
." -Mini Editor- " $header
;
: ll ( line# -- )
dup $c/l * $buf + $c/l type space 0 <# # # #> type
;
: list ( addr -- )
0 begin cr dup ll 1+ dup 16 = until drop
;
: !xy ( i -- i ) 1023 and dup $c/l /mod 1+ $at-xy ;
: !ch ( c i -- c i ) 2dup $buf + c! over emit ;
: ?ch ( c i -- c i' )
over bl - 95 u< if !ch 1+ exit then
over 8 = if 1- then ( left backspace )
over 127 = if 1- then ( left delete )
over 12 = if 1+ then ( right )
over 11 = if $c/l - then ( up )
over 10 = if $c/l + then ( down )
over 13 = if $c/l 2dup mod - + then ( cr )
\ mx1 ( <- uncomment and put extensions here )
;
external
: $edit ( addr -- )
to $buf
$page 0 dup $at-xy head list 0
begin !xy key swap ?ch swap 27 = until drop $page 0 dup $at-xy
;
: new-ram-screen
1024 alloc-mem dup 1024 blank
;
: load-ram-screen
1024 $-trailing eval
;
s" previous set-current" evaluate
." loaded!" cr
fcode-end

12
fcode-modules/makemod.sh Executable file
View File

@ -0,0 +1,12 @@
#!/bin/bash
# This script tokenizes FCode via toke and prepends a small header for identification
# by the ROM scanner (currently only implemented for the W65C816SXB).
cd `dirname ${0}`
if [ -r "${1}.fs" ]; then
toke "${1}.fs"
echo -n "MGFC" | cat - "${1}.fc" > ${1}.rom
else
echo "No source for ${1}!"
fi

5
fcode-modules/test.fs Normal file
View File

@ -0,0 +1,5 @@
start1
." This is a test!" cr
fcode-end

29
forth.s Normal file
View File

@ -0,0 +1,29 @@
; Master build file for OF816
.p816
.a16
.i16
; System segment
.segment "FSystem"
.include "macros.inc" ; System macros
.include "platform.inc" ; Set up by the build script
.include "config.inc" ; Configuration defines
.include "equates.inc" ; Equates
.include "asm/system.s" ; System interfacing
.include "asm/interpreter.s" ; Inner interpreter & helpers
.include "asm/compiler.s" ; Compiler helpers
.include "asm/mathlib.s" ; Math library
.include "asm/memmgr.s" ; Memory (heap) management library
PLATFORM_INCLUDE "platform-lib.s" ; Platform library
.include "asm/env-dictionary.s" ; Environmental queries dictionary
.include "asm/forth-dictionary.s" ; Forth built-in dictionary
; FCode segment - to be potentially located in a different bank
.if include_fcode
.pushseg
.segment "FCode"
.include "asm/fcode.s"
.popseg
.endif

52
inc/equates.inc Normal file
View File

@ -0,0 +1,52 @@
; *** Direct page equates ***
.pushseg
.zeropage
STACKBASE = $00 ; normally 0
ZR = $00 ; 0 four scratch cells
WR = ZR+4 ; 4
XR = WR+4 ; 8
YR = XR+4 ; c
IP = YR+4 ; 10 instruction pointer
STK_BTM = IP+4 ; 14 lowest bank 0 address usable for stack
STK_TOP = STK_BTM+2 ; 16 bank 0 address immediately after the upper stack cell
RSTK_TOP = STK_TOP+2 ; 18 return stack top
SYS_RSTK = RSTK_TOP+2 ; 1a system return stack pointer
DHERE = SYS_RSTK+2 ; 1c HERE system variable
MEM_BTM = DHERE+4 ; 20 System memory bottom
MEM_TOP = MEM_BTM+4 ; 24 System memory top
SYSVARS = MEM_TOP+4 ; 28 Pointer to system variables
RSTK_SAVE = SYSVARS+4 ; 2c return stack saved for current CATCH level
CATCHFLAG = RSTK_SAVE+2 ; 2e active catch counter
SYSIF = CATCHFLAG+2 ; 30 system interface vector, 4 bytes
DP_END = SYSIF+4 ; 34 must be last so platform libs can used DP
;TMP1 = SYSIF+4 ; 34 temp for ENTER
;DP_END = TMP1+2 ; 36 must be last so platform libs can use DP
.popseg
; *** system interface function codes ***
SI_PRE_INIT = $0000
SI_POST_INIT = $0001
SI_EMIT = $0002
SI_KEYQ = $0003
SI_KEY = $0004
SI_GET_FCODE = $0005
SI_RESET_ALL = $0006
; *** Constants ***
opJSL = $22
opJML = $5C
c_bell = $07
c_bs = $08
c_cr = $0D
c_lf = $0A
c_page = $0C
c_del = $7F
; *** Processor ***
RESETV = $FFFC
; *** System Info ***
.define VERSION "0.1"

396
inc/macros.inc Normal file
View File

@ -0,0 +1,396 @@
; Macro library for OF816. Contains macros for hand-compiled Forth code and common
; ops used within primitives. Also contains macros for building dictionaries.
; Config/build macros
.macro PLATFORM_INCLUDE file
.if .strlen(PLATFORM) > 0
.out .sprintf("Including text platforms/%s/%s", PLATFORM, file)
.include .sprintf("platforms/%s/%s", PLATFORM, file)
.endif
.endmacro
.macro PLATFORM_INCBIN file
.if .strlen(PLATFORM) > 0
.out .sprintf("Including binary platforms/%s/%s", PLATFORM, file)
.incbin .sprintf("platforms/%s/%s", PLATFORM, file)
.endif
.endmacro
; General macros & defs
.define SHORT_A %00100000
.define SHORT_I %00010000
;.macro LDAY val
; ldy .loword(val)
; lda .hiword(val)
;.endmacro
; Forth macros
; Enter inner interpreter with 32-bit absolute addresses
.macro ENTER
jsl _enter
.endmacro
.macro EXIT
.dword _exit_next-1
.endmacro
.macro CODE
.dword _exit_code-1
.endmacro
.macro NEXT
jmp _next
.endmacro
.macro LNEXT
jml f:_next
.endmacro
.macro PUSHNEXT
jmp _next::fast_num
.endmacro
.macro LPUSHNEXT
jml f:_next::fast_num
.endmacro
.macro RUN
jmp _next::run
.endmacro
.macro LRUN
jml f:_next::run
.endmacro
; This version always stores one or two cell-sized objects
.macro NLIT num
.if .const(num)
.if .hiword(num) > 0 || no_fast_lits
.dword _LIT
.endif
.word .loword(num)
.word .hiword(num)
.else
.dword _LIT
.dword num
.endif
.endmacro
; This version will use the most optimal
; storage for the literal in question
.macro ONLIT num
.if .const(num)
.if .hiword(num) > 0 ; big numbers are always expensive
.dword _LIT
.word .loword(num)
.word .hiword(num)
.elseif no_fast_lits ; if no fast literals, right-size it
.if .hibyte(num) > 0
.dword _WLIT
.word num
.else
.dword _CLIT
.byte num
.endif
.else ; fast literals are the cheapest when available
.word .loword(num)
.word .hiword(num)
.endif
.else
NLIT num ; non-const expressions get a cell
.endif
.endmacro
.macro JUMP target
.dword _JUMP
.dword target
.endmacro
.macro BRANCH target
.dword _BRANCH
.addr target-*
.endmacro
.if 0
; Macro for a string literal ( -- c-addr u )
.macro OLDSLIT str
.local target,addr
JUMP target
addr:
.byte str
target:
NLIT addr
NLIT .strlen(str)
.endmacro
.endif
.macro SLIT str
.dword _SLIT
.dword .strlen(str)
.byte str
.endmacro
; Macro for a counted string literal ( -- c-addr )
.macro CSLIT str
.local target,addr
JUMP target
addr:
.byte .strlen(str)
.byte str
target:
NLIT addr
.endmacro
.macro FCONSTANT value
ldy #.loword(value)
lda #.hiword(value)
PUSHNEXT
.endmacro
; Can't be used in ROMable code
.macro FVARIABLE value
jsl _pushda
val: .dword value
.endmacro
; Can't be used in ROMable code
.macro FVALUE value
jsl _pushconst
val: .dword value
.endmacro
; Can't be used in ROMable code
.macro DEFER adr
jsl _deferred
val:
.ifblank adr
.dword _unimpl
.else
.dword adr
.endif
.endmacro
.macro FFIELD offset
jsl _field
.dword offset
.endmacro
NUM_SYSVARS .set 0
.macro DEF_SYSVAR num,name
.assert num=NUM_SYSVARS, error, "System variable defined out-of-order"
name = num*4
NUM_SYSVARS .set NUM_SYSVARS+1
.endmacro
.macro SYSVAR num
jsl _sysvar
.dword num
.endmacro
.macro SYSVAR_INIT name
.assert .sizeof(name)=NUM_SYSVARS*4,error,.sprintf("SYSVAR_INIT: size incorrect, should be %i dwords",NUM_SYSVARS)
.endmacro
.macro FSTR str
.local target,thestr
ldy #<.loword(thestr)
lda #>.hiword(thestr)
jsr _pushay
ldy #<.strlen(str)
lda #>.strlen(str)
jsr _pushay
bra target
thestr: .byte str
target:
.endmacro
.macro TRACE name
.ifblank name
jsr _named_trace
.byte name
.else
jsr _word_trace
.endif
.endmacro
; Dictionary structure macros
; Dictionary format:
; Bytes Purpose
; Header (scope H_<name>)
; 4 Link to previous (0=end of dictionary), not present for "headerless" words
; 1 Name Length, high bit always set (max=127)
; n Name (high bits clear), if present
; 1 Flags
; b7 - Immediate
; b6 - Compile-only
; b0 - Smudge
; Code (scope <name>)
.define F_IMMED %10000000 ; immediate
.define F_CONLY %01000000 ; compile-only
.define F_PROT %00100000 ; begin system protection (from FORGET, etc.)
.define F_TEMPD %00010000 ; word initiates or finishes temporary definition
.define F_SMUDG %00001000 ; smudged, invisible in search
.define NAMEMSK %01111111 ; name length mask
.macro dstart dictname
.ifdef c_dict
.error "%s dictionary not closed",.string(c_dict)
.endif
.define c_dict dictname
.ifndef __dstart
__dstart = 0
.endif
.define l_dword __dstart ; last defined word
.endmacro
.macro dhead link,dname,fname
.if print_dict && .strlen(fname) > 0
.if .const(*)
.out .concat(fname, .sprintf(" def at $%x", *))
.else
.out .concat(fname, " def starts")
.endif
.elseif print_dict
.if .const(*)
.out .concat(.string(dname), .sprintf(" def at $%x", *))
.else
.out .concat(.string(dname), " def starts")
.endif
.endif
.proc .ident(.sprintf("H_%s",.string(dname)))
.if .strlen(fname) > 0
.dword link
.byte .strlen(fname)|$80
.byte fname
.else
.byte $80
.endif
.endproc
.endmacro
.macro dword dname,fname,flags
.ifdef c_dword
.error .sprintf("%s def not closed",.string(c_dword))
.endif
.if .strlen(fname) > 0
.define c_dword .ident(.sprintf("H_%s",.string(dname)))
.endif
dhead l_dword,dname,fname
.proc dname
.if print_dict && .const(*)
.out .sprintf(" xt at $%x", *)
.endif
; flag byte here so that XT is code addr - 1
.ifblank flags
.byte F_PROT
.else
.byte flags|F_PROT
.endif
code:
.if trace
wdm $80 ; for emulator debugger
.endif
.endmacro
.macro hword dname,fname,flags
.if no_headerless
.ifblank flags
dword dname,fname
.else
dword dname,fname,flags
.endif
.else
.ifblank flags
dword dname,""
.else
dword dname,"",flags
.endif
.endif
.endmacro
.macro dwordq dname,fname,flags
.charmap $27,$22 ; temporarily map single quote to double quote
.ifblank flags
dword dname,fname
.else
dword dname,fname,flags
.endif
.charmap $27,$27 ; unmap
.endmacro
.macro dchain dname
.ifdef l_dword
.undefine l_dword
.endif
.define l_dword dname
.endmacro
.macro eword
.endproc
.ifdef c_dword
dchain c_dword
.undefine c_dword
.endif
.endmacro
.macro denvq dname,fname,value,value2
dword dname,fname
.ifblank value2
jsl _pushvalue
.dword value
.else
jsl _push2value
.dword value2
.dword value
.endif
eword
.endmacro
.macro dend
.ident(.sprintf("LAST_%s",c_dict)) = l_dword
.undef c_dict
.endmacro
; outside-of-dictionary headerless words
; mainly to support FCode features
.macro xdword dname,flags
.proc .ident(.sprintf("H_%s",.string(dname)))
.byte $80
.endproc
.proc dname
.ifblank flags
.byte F_PROT
.else
.byte flags|F_PROT
.endif
code:
.endmacro
.macro exdword
.endproc
.endmacro
; FCode macros
.define FC_ROMFLAG $80000000
.define FC_IMMFLAG $80000000
; These get around stupid address size calculation probs in the linker
.macro FCROM addr
.faraddr addr
.byte .hibyte(.hiword(FC_ROMFLAG))
.endmacro
.macro FCIMM addr
.faraddr addr
.byte .hibyte(.hiword(FC_IMMFLAG))
.endmacro

15
platforms/IIgs/IIgs.l Normal file
View File

@ -0,0 +1,15 @@
FEATURES {
STARTADDRESS: default = $2000;
}
MEMORY {
RAM: start = $2000, size = $9E00, file = %O;
ZP: start = $0000, size = $100;
}
SEGMENTS {
FStartup: load=RAM, type=rw;
FSystem: load=RAM, type=ro;
FCode: load=RAM, type=ro, optional=yes;
ZEROPAGE: load=ZP, type=bss;
}

203
platforms/IIgs/IIgs.s Normal file
View File

@ -0,0 +1,203 @@
.p816
.a8
.i8
.include "platform-config.inc"
.include "macros.inc"
.include "equates.inc"
.include "platform-include.inc"
.import _Forth_initialize
.import _Forth_ui
.import _system_interface
.pushseg
.segment "FStartup"
; In the IIgs we enter here at $2000 in emulation mode from ProDOS 8
bra startup
MasterId: .word 0
;UserId: .word 0 ; Now in page 3
BankLoad: .word 0
Bnk0Hnd: .dword 0
Bnk1Hnd: .dword 0
DataHnd: .dword 0
.proc startup
sec
jsr IDRoutine
bcc :+
jmp quit
: lda #$C3
sta CON_RD+1
sta CON_WR+1
sta CON_ST+1
sta ECALL+1
lda $C30D
sta ECALL
lda $C30E
sta CON_RD
lda $C30F
sta CON_WR
lda $C310
sta CON_ST
ldx #$00
jsr (ECALL,x)
lda #'0'
sta $800
clc
xce
rep #SHORT_A|SHORT_I
.a16
.i16
phk
plb
jsr _prep_tools ; get the GS toolbox ready to use
pea $0000 ; now let's ask for memory for the data space
pea $0000 ; result space
lda #.hiword(data_space_size)
pha
lda #.loword(data_space_size)
pha
lda f:UserId
pha
lda #%1100000000001100 ; locked, unpurgeable, page-align, may cross banks
pha
pea $0000
pea $0000
_NewHandle
ply ; low byte
plx ; high byte
_Err
sty DataHnd ; save the handle for later deref
stx DataHnd+2
; now we can start the Forth initialization
; we need to set direct page and then push the remaining initialization
; parameters onto the (system) return stack.
lda #$0800 ; direct page for Forth
tcd
sty ZR ; put DataHnd in ZR for deref
stx ZR+2
lda #$0000 ; top of data space, will store later
pha
pha
ldy #$0000
lda [ZR],y ; dereferenced low byte
tax
clc
adc #.loword(data_space_size)
sta 1,s ; update top of data space low word
iny
iny
lda [ZR],y ; dereferenced high byte
pha
adc #.hiword(data_space_size)
sta 5,s ; update top of data space high word
phx
lda #$0300 ; first usable stack cell (relative to direct page)
pha ; $800 + $0300 = $0B00
lda #$0100 ; last usable stack cell+1 (relative to direct page)
pha ; $800 + $0100 = $0900
lda #$0DFF ; return stack first usable byte
pha
lda #.hiword(_system_interface)
pha
lda #.loword(_system_interface)
pha
lda #'1'
sta $800
jsl _Forth_initialize
lda #'2'
sta $800
jsl _Forth_ui
lda #'3'
sta $800
; When Forth returns, BYE was executed, clean up and quit
lda #$0000 ; restore direct page to page 0
tcd
.if 0
lda f:UserId
pha
_DisposeAll
.else
ldx DataHnd+2 ; dispose of our data space
ldy DataHnd
phx
phy
_DisposeHandle
.endif
_Err
lda f:UserId
pha
_MMShutDown ; Shut down memory manager
quit: sec ; exit back to P8 or GS/OS
xce
.a8
.i8
jsr MLI
.byte $65
.addr p_QUIT
brk
.byte $00
p_QUIT: .byte 4
.byte 0
.addr 0
.byte 0
.addr 0
.endproc
.a16
.i16
; Thanks to Dagen Brock for this, adapted from:
; https://github.com/digarok/gslib/blob/master/source/p8_tools.s
.proc _prep_tools
stz MasterId ; Clear Master ID
_TLStartUp ; start Tool Locator
pha ; result space
_MMStartUp ; start Memory Manager
pla ; User ID
bcs :+
brl MM_OK
: _MTStartUp ; start Misc Tools
pha ; result space
pea $1000 ; b15-12 $1 = Application
_GetNewId ; get a new user ID
pla
sta MasterId ; save it
pha ; result space
pha
pea $0000 ; block size ($0000B800)
pea $B800
lda MasterId
pha ; User ID
pea $C002 ; attributes (locked, fixed, unmovable)
pea $0000 ; location ($00000800)
pea $0800
_NewHandle
ply ; get handle for bank 0
plx
_Err
sty Bnk0Hnd
stx Bnk0Hnd+2
pha ; now do bank 1
pha
pea $0000
pea $B800
lda MasterId
pha
pea $C002
pea $0001
pea $0800
_NewHandle
ply ; get handle for bank 1
plx
_Err
sty Bnk1Hnd
stx Bnk1Hnd+2
pha ; result space
_MMStartUp
pla
_Err
MM_OK: sta f:UserId
rts
.endproc
.popseg

124
platforms/IIgs/README.md Normal file
View File

@ -0,0 +1,124 @@
# OF816 for Apple IIgs
This is a port to the Apple IIgs system, the most commercially-successful
personal computer to use the 65C816. The build.sh script builds a ProDOS SYS
file (note: not a GS/OS S16 file) that can be launched from GS/OS or ProDOS 8,
or even as the PRODOS file on a disk with a ProDOS boot block.
The port has the following system-specific features:
* ``BYE`` returns to the launching OS.
* Data space allocated from the GS ToolBox Memory Manager.
* Console I/O through the slot 3 Pascal 1.1 fimrware interface.
* ANSI terminal emulation as required by IEEE 1725-1994, except (for now)
Insert Character and Delete Character, with additional non-required codes.
* GS Toolbox call support.
* ProDOS 8 MLI call support.
* Some pre-canned spaces reserved in bank 0 for buffers, etc.
## Building
You may need to modify the build script. It currently uses AppleCommander (a
Java-based Apple II disk image utility) to make a disk image suitable for
emulators.
## Platform-Specific Words
* ``LINE#`` ( -- u ) return cursor vertical position.
* ``COLUMN#`` ( -- u ) return cursor horizontal position.
* ``$GS-USERID`` ( -- u ) return the ToolBox user ID of the Forth system.
* ``$GS-TOOLCALL`` ( i\*n i tbyte1 j tybet2 tool# -- j\*n ) Call Apple IIgs
toolbox call tool#, putting i items on the return stack before the call,
with sizes specified in the bits in tbyte1 (0 = word, 1 = long), and
retrieving j items from the return stack after the call, with sizes
specified by the bits in tbyte2. Note that the parameters go onto the
return stack in the opposite order they are on the parameter stack.
* ``$P8-CALL`` ( call# addr ) call ProDOS 8 function call#, with paramter
list at addr.
* ``$P8-BUFS`` ( -- addr ) return address of memory that can be used for
ProDOS 8 buffers.
* ``$P8-#BUFS`` ( -- u ) the total number of $400-byte buffers at ``$P8-BUFS``
* ``$P8-PPAD`` ( -- addr ) address of a $100-byte scratchpad that can be used
as a space to assemble ProDOS call parameters.
* ``$P8-RWBUF`` ( -- addr ) address of a $100-byte space that can be used for
a data buffer for ProDOS calls.
* ``$P8-BLKBUF`` ( -- addr ) address of a $400-byte space that can be used
as a block data buffer to implement the block word set.
Note that none of the File or Block word sets are implemented, but they may
be implemented on top of the above.
Some pre-canned toolbox calls:
* ``_TOTALMEM`` ( -- u ) return size of memory installed in system.
* ``_READBPARAM`` ( u1 -- u2 ) read battery RAM parameter u1.
* ``_READTIMEHEX`` ( -- u1 u2 u3 u4 ) read time in hex format.
* ``_READASCIITIME`` ( addr -- ) read 20 byte time string into buffer at addr.
* ``_FWENTRY`` ( addr y x a -- y x a p ) call firmware entry in bank 0.
* ``_SYSBEEP`` ( -- ) play the system bell.
* ``_SYSFAILMGR`` ( addr u -- ) call fatal error handler, u = error code and
addr = address of packed string message or 0 for default message.
Example implementation of the pre-canned system calls to show how
``$GS-TOOLCALL`` is used:
```
HEX
: _TOTALMEM 0 0 1 1 1D02 $GS-TOOLCALL ;
: _READBPARAM 1 0 1 0 C03 $GS-TOOLCALL ;
: _READTIMEHEX 0 0 4 0 D03 $GS-TOOLCALL ;
: _READASCIITIME 1 1 0 0 F03 $GS-TOOLCALL ;
: _FWENTRY 4 0 4 0 2403 $GS-TOOLCALL ;
: _SYSBEEP 0 0 0 0 2C03 $GS-TOOLCALL ;
: _SYSFAILMGR 2 2 ( %10 ) 0 0 1503 $GS-TOOLCALL ;
```
## Internals
The Apple IIgs port initializes the GS Toolbox if necessary, and then requests
memory for the data space from the Memory Manager (amount defined in
``platform-config.inc``). This memory is released when ``BYE`` is executed.
The startup code captures the Pascal I/O vectors for slot 3 and puts them in
page 3, to be later used by the System Interface Function.
Bank 0 memory map:
```
+--------------------------------+ $FFFF
| |
| ROM |
| |
+--------------------------------+ $D000
| I/O |
+--------------------------------+ $C000
+ ProDOS global page |
+--------------------------------| $BF00
| |
| |
| Forth System |
| |
| |
+--------------------------------| $2000
| BLKBUF ($400) |
| IOBUF0-2 ($400 each) |
+--------------------------------+ $1000
| PPAD ($100) |
| RWBUF ($100) |
|--------------------------------| $0E00
| Forth Return Stack |
+--------------------------------| $0B00
| Forth Parameter Stack |
+--------------------------------| $0900
| Forth Direct Page |
+--------------------------------| $0800
| Text Page 0 (screen) |
+--------------------------------| $0400
| Sys. Vectors and Scratch |
+--------------------------------| $0300
| System Input Buffer (unused) |
+--------------------------------| $0200
| System Return Stack |
+--------------------------------| $0100
| System Direct Page |
+--------------------------------| $0000
```

9
platforms/IIgs/build.sh Executable file
View File

@ -0,0 +1,9 @@
#!/bin/bash
ACMD=~/bin/AppleCommander-ac-1.5.0.jar
set -e -x
ca65 -I ../../inc IIgs.s -l IIgs.lst
../../build.sh IIgs
ld65 -C IIgs.l -S 0x8000 IIgs.o ../../forth.o -m forth.map -o forth
ls -l forth
java -jar ${ACMD} -pro140 forth.po FORTH
java -jar ${ACMD} -p forth.po FORTH SYS < forth

3
platforms/IIgs/platform-config.inc Normal file
View File

@ -0,0 +1,3 @@
; Data space size to allocate from the memory manager
data_space_size = 32768

108
platforms/IIgs/platform-include.inc Normal file
View File

@ -0,0 +1,108 @@
; System page 0 stuff; note, address absolute
_CH = $57B ; cursor horizontal position
_CV = $5FB ; cursor vertical position
; these don't seem to be respected by the Pascal 1.1 interface and keep
; getting reset to their default values
_WL = $20 ; window left
_WW = $21 ; window width
_WT = $22 ; window top
_WB = $23 ; window bottom
; System firmware routines
IDRoutine = $FE1F ; identify IIgs
Reset = $FA62 ; reset handler
Scroll = $FC70 ; scroll up
; These are at page 3
DPSAVE = $300 ; save direct page reg for native calls
SPSAVE = DPSAVE+2 ; save stack pointer for native cxalls
CON_RD = SPSAVE+2 ; Pascal Read for slot 3
CON_WR = CON_RD+2 ; Pascal Write for slot 3
CON_ST = CON_WR+2 ; Pascal Status for slot 3
ECALL = CON_ST+2 ; address of routine to call in emulation mode
AREG = ECALL+2 ; temporary A register storage for native calls
ESCMODE = AREG+2 ; ESC mode for OF terminal emu
ESCACC = ESCMODE+2 ; accumulator for OF terminal emu
ESCNUM1 = ESCACC+2 ; first number of two-number ESC code
MNUM2 = ESCNUM1+2 ; factor for converting numbers
UserId = MNUM2+2 ; UserId for toolbox calls that need it
PwrByte = $3F4 ; Reset vector check byte
MLI = $BF00 ; ProDOS 8 MLI
ToolCall = $E10000 ; Entry for IIgs ToolBox calls
IOBufs = $1000 ; space for file buffers
IOBuf_Cnt = 3
Blk_Buf = $1C00 ; block buffer
PPad = $0F00 ; scracthpad for making parameter lists for P8
RWBuf = $0E00
; Hardware
STO80_OFF = $C000 ; turn off 80 store
STO80_ON = $C001 ; turn on 80 store
TXTPAGE1 = $C054 ; set text page 1
TXTPAGE2 = $C055 ; set text page 2
.macro Tool callnum
ldx #callnum
jsl f:ToolCall
.endmacro
.macro _TLStartUp
Tool $201
.endmacro
.macro _TLShutDown
Tool $301
.endmacro
.macro _NewHandle
Tool $902
.endmacro
.macro _MMStartUp
Tool $202
.endmacro
.macro _GetNewId
Tool $2003
.endmacro
.macro _MTStartUp
Tool $203
.endmacro
.macro _DisposeHandle
Tool $1002
.endmacro
.macro _DisposeAll
Tool $1102
.endmacro
.macro _MMShutDown
Tool $302
.endmacro
.macro _SysFailMgr
Tool $1503
.endmacro
.macro _Err msg
.local okay, die
bcc okay
pha
.ifblank msg
pea $0000
pea $0000
.else
pea .hiword(msg)
pea .loword(msg)
bra die
.byte .strlen(msg),msg
.endif
die: _SysFailMgr
okay:
.endmacro

594
platforms/IIgs/platform-lib.s Normal file
View File

@ -0,0 +1,594 @@
; Note: we *know* this is running in bank 0
cpu_clk = 2800000 ; nominally
PLATFORM_INCLUDE "platform-include.inc"
.proc _scrn_tab
.addr $400
.addr $480
.addr $500
.addr $580
.addr $600
.addr $680
.addr $700
.addr $780
.addr $428
.addr $4A8
.addr $528
.addr $5A8
.addr $628
.addr $6A8
.addr $728
.addr $7A8
.addr $450
.addr $4D0
.addr $550
.addr $5D0
.addr $650
.addr $6D0
.addr $750
.addr $7D0
.endproc
.proc _system_interface
phx
asl
tax
jmp (table,x)
table: .addr _sf_pre_init
.addr _sf_post_init
.addr _sf_emit
.addr _sf_keyq
.addr _sf_key
.addr _sf_fcode
.addr _sf_reset_all
.endproc
.export _system_interface
.proc _emulation_call
sta AREG
tdc
sta f:DPSAVE
tsc
sta f:SPSAVE
lda SYS_RSTK
tcs
lda #$0000
tcd
lda AREG
sec
xce
.a8
.i8
ldx #$00
jsr (ECALL,x)
php ; save carry state
clc
xce ; back to native
plp ; get it back
rep #SHORT_A|SHORT_I ; go to long registers
.a16
.i16
sta AREG ; save A while we do this thing
lda f:SPSAVE
tcs
lda f:DPSAVE
tcd
lda AREG
rts
.endproc
; A=call number, Y=address
.proc _p8_call
sty plist
sep #SHORT_A
.a8
sta callnum
rep #SHORT_A
.a16
tdc
sta f:DPSAVE
tsc
sta f:SPSAVE
lda SYS_RSTK
tcs
lda #$0000
tcd
sec
xce
.a8
.i8
jsr MLI
callnum: .byte $00
plist: .addr $0000
php
clc
xce
plp
rep #SHORT_A|SHORT_I
.a16
.i16
and #$00FF
sta AREG
lda f:SPSAVE
tcs
lda f:DPSAVE
tcd
lda AREG
rts
.endproc
.proc _sf_success
lda #$0000
tay
clc
rtl
.endproc
.proc _sf_fail
ldy #.loword(-21)
lda #.hiword(-21)
sec
rtl
.endproc
.proc _sf_pre_init
; Most initialization happens outside of the Forth system
stz ESCMODE
plx
bra _sf_success
.endproc
.proc _sf_post_init
plx
bra _sf_success
.endproc
.proc _sf_emit
phk ; ensure we are working with bank 0
plb
plx
jsr _popay
phx
cpy #$00
beq do_null ; ignore nulls
lda ESCMODE
asl
tax
jmp (table,x)
table: .addr _mode0 ; no ESC sequence in progress
.addr _mode1 ; ESC but no [ yet
.addr _mode2 ; ESC[ in progress
do_null: plx
jmp _sf_success
.endproc
.proc _mode0
cpy #$1B ; ESC
bne :+
inc ESCMODE
bra done
: cpy #$0B ; OF code for cursor up
bne :+
ldy #$1F ; Apple II code for cursor up
: jsr _con_write
done: plx
jmp _sf_success
.endproc
.proc _mode1
cpy #'[' ; second char in sequence?
beq :+ ; yes, change modes
stz ESCMODE ; otherwise back to mode 0
phy
ldy #$1B
jsr _con_write ; output the ESC we ate
ply
jsr _con_write ; and output this char
bra done
: stz ESCACC
stz ESCNUM1
inc ESCMODE ; sequence started!
done: plx
jmp _sf_success
.endproc
.proc _mode2
cpy #' ' ; ignore spaces in codes
beq done
cpy #';'
bne :+
lda ESCACC ; move ACC to NUM1 if ;
sta ESCNUM1 ; note that only supports two params!
stz ESCACC
bra done
: tya
sec
sbc #$30
bmi endesc ; eat it and end ESC mode if invalid
cmp #$0a
bcs :+ ; try letters if not a digit
tay ; a digit, accumulate it into ESCACC
lda #10 ; multiply current ESCACC by 10
sta MNUM2
lda #$0000 ; initialize result
beq elp
do_add: clc
adc ESCACC
lp: asl ESCACC
elp: lsr MNUM2
bcs do_add
bne lp
sta ESCACC ; now add the current digit
tya
clc
adc ESCACC
sta ESCACC
bra done
: tya ; not a digit, try letter codes
sbc #'@' ; carry was set above
bmi endesc
cmp #$1B ; ctrl+Z
bcc upper ; upper case code
sbc #$20 ; convert lower case to 00-1A
bmi endesc
cmp #$1B
bcc lower ; lower case codes
endesc: stz ESCMODE
done: plx
jmp _sf_success
none: rts
upper: asl
tax
jsr (utable,x)
bra endesc
utable: .addr ich ; @ insert char
.addr cuu ; A cursor up
.addr cud ; B cursor down
.addr cuf ; C cursor forward
.addr cub ; D cursor backward
.addr cnl ; E cursor next line
.addr cpl ; F cursor previous line
.addr cha ; G cursor horizontal absolute
.addr cup ; H cursor position
.addr none ; I
.addr ed ; J erase display
.addr el ; K erase line
.addr il ; L insert lines
.addr dl ; M delete lines
.addr none ; N
.addr none ; O
.addr dch ; P delete char
.addr none ; Q
.addr none ; R
.addr su ; S scroll up
.addr sd ; T scroll down
.addr none ; U
.addr none ; V
.addr none ; W
.addr none ; X
.addr none ; Y
.addr none ; Z
lower: asl
tax
jsr (ltable,x)
bra endesc
ltable: .addr none ; `
.addr none ; a
.addr none ; b
.addr none ; c
.addr none ; d
.addr none ; e
.addr cup ; f cursor position
.addr none ; g
.addr none ; h
.addr none ; i
.addr none ; j
.addr none ; k
.addr none ; l
.addr sgr ; m set graphic rendition
.addr none ; n device status report (requires input buffer)
.addr none ; o
.addr none ; p normal screen (optional)
.addr none ; q invert screen (optional)
.addr none ; r
.addr none ; s reset screen (optional)
.addr none ; t
.addr none ; u
.addr none ; v
.addr none ; w
.addr none ; x
.addr none ; y
.addr none ; z
; cursor up
cuu: ldy #$1F
jmp con_wr_n
; cursor down
cud: ldy #$0A
jmp con_wr_n
; cursor forward
cuf: ldy #$1C
jmp con_wr_n
; cursor backwards
cub: ldy #$08
jmp con_wr_n
; cursor previous line
cpl: jsr cuu
bra :+ ; eventually repos cursor
; cursor next line
cnl: jsr cud
: lda #$0001 ; set horizontal position to 1
sta ESCACC
; fall-through to CHA
; cursor horizontal absolute
cha: lda a:_CV ; get current cursor vertical
and #$00FF
inc a ; because ANSI counts from 1...
sta ESCNUM1
; fall-through to CUP
; cursor position
cup: ldx ESCACC
beq :+ ; if it's zero, leave it as such
dex
: ldy ESCNUM1
beq :+
dey
: jmp _goto_xy
; erase display
ed: lda ESCACC
beq clreos
dec a
bne :+
rts ; if 1, clear from beginning to cursor (not supported)
: lda _CV ; otherwise clear whole screen
and #$FF
pha
lda _CH
and #$FF
pha
jsr clrscr
plx
ply
jmp _goto_xy
clrscr: ldy #$0C
jmp _con_write
clreos: ldy #$0B
jmp _con_write
; erase line
el: ldy #$1D ; clear to end of line
lda ESCACC
beq :+
cmp #$02
bne :++
erase_ln: ldy #$1A ; clear entire line
: jmp _con_write
: rts
; insert line, cheat because no native function in firmware
; scroll the lines downward and then exit through erase_ln
il: jsr _cursor_off
jsr do_il
dec ESCACC
bmi :+
beq :+
bra il
: jmp _cursor_on
do_il: lda #23 ; start at line 23 and move toward CV
sta ZR ; source line
: lda _CV ; is it the current line?
and #$FF
cmp ZR
beq erase_ln ; it is, erase it
jsr _80store_on
lda ZR
asl
tax
ldy _scrn_tab,x ; get dest line address TODO change back to LDY
dec ZR ; next lower line
lda ZR
asl
tax
lda _scrn_tab,x ; get source line address
tax
jsr _copy_line
jsr _80store_off
bra :-
; delete line
dl: jsr _cursor_off
jsr do_dl
dec ESCACC
bmi :+
beq :+
bra dl
: jmp _cursor_on
do_dl: lda _CV ; start at CV and move toward line 23
and #$FF
sta ZR
: lda ZR ; dest line
cmp #23 ; is it 23?
bne :+ ; no, go move the lines
lda _CV ; save current cursor pos
and #$FF
pha
lda _CH
and #$FF
pha
tax
ldy #23 ; position on bottom line
jsr _goto_xy
jsr erase_ln ; and clear it out
plx
ply
jmp _goto_xy
: jsr _80store_on
lda ZR
asl
tax
ldy _scrn_tab,x
inc ZR
lda ZR
asl
tax
lda _scrn_tab,x
tax
jsr _copy_line
bra :--
; insert char
ich: rts ; unimplemented
; delete char
dch: rts ; unimplemented
; set graphic rendition
sgr: lda ESCACC
cmp #10
beq mtoff
bcc :+
cmp #20
bcc mton
rts
: and #$01
clc
adc #$0E ; $0E = normal, $0F=inverse
tay
jsr _con_write
rts
mton: sty ESCNUM1
ldy #$1B
jsr _con_write
ldy #$0F
bra _con_write
mtoff: ldy #$18
jsr _con_write
ldy #$0E
bra _con_write
; scroll up
sd: ldy #$16
bra con_wr_n
su: ldy #$17
; fall-through
con_wr_n: sty ESCNUM1
: jsr _con_write
dec ESCACC
bmi :+
beq :+
ldy ESCNUM1
bra :-
: rts
.endproc
.proc _con_write
lda CON_WR
sta ECALL
tya
ldx #$C3 ; required by P1.1 I/F
ldy #$30
jmp _emulation_call
.endproc
.proc _cursor_off
ldy #$06
bra _con_write
.endproc
.proc _cursor_on
ldy #$05
bra _con_write
.endproc
.proc _goto_xy
phy
phx
ldy #$1E
jsr _con_write
pla ; x coord
clc
adc #32
tay
jsr _con_write
pla ; y coord
clc
adc #32
tay
bra _con_write
.endproc
; copy screen line, source base in X, dst base in Y
.proc _copy_line
phb
phy
phx
lda #38 ; # of chars MINUS ONE
mvn $00,$00 ; do main ram bytes
sep #SHORT_A
sta TXTPAGE2
rep #SHORT_A
plx
ply
lda #38
mvn $00,$00 ; do aux ram bytes
sep #SHORT_A
sta TXTPAGE1
rep #SHORT_A
plb
rts
.endproc
.proc _80store_on
sep #SHORT_A
sta STO80_ON
rep #SHORT_A
rts
.endproc
.proc _80store_off
sep #SHORT_A
sta STO80_ON
rep #SHORT_A
rts
.endproc
.proc _sf_keyq
lda CON_ST
sta ECALL
lda #$01 ; check input status
ldx #$C3 ; required by P1.1 I/F
ldy #$30
jsr _emulation_call
ldy #$0000
bcc :+ ; if not ready
dey
: tya
plx
jsr _pushay
jmp _sf_success
.endproc
.proc _sf_key
lda CON_RD
sta ECALL
: ldx #$C3 ; required by P1.1 I/F
ldy #$30
jsr _emulation_call
and #$00FF
beq :- ; reject nulls
tay
lda #$0000
plx
jsr _pushay
jmp _sf_success
.endproc
.proc _sf_fcode ; none for now
lda #$0000
tay
plx
jsr _pushay
jmp _sf_success
.endproc
.proc _sf_reset_all
lda #Reset
sta ECALL
inc PwrByte
jsr _emulation_call
jmp _sf_fail
.endproc

207
platforms/IIgs/platform-words.s Normal file
View File

@ -0,0 +1,207 @@
; TODO: implement indirect values, this will help with all kinds of things
; including making these mutable
; H: ( -- u ) cursor line #
dword LINEn,"LINE#"
ENTER
ONLIT _CV
.dword CFETCH
EXIT
eword
; H: ( -- u ) cursor line #
dword COLUMNn,"COLUMN#"
ENTER
ONLIT _CH
.dword CFETCH
EXIT
eword
; H: ( -- u ) memory manager user ID for this process
dword dGS_USERID,"$GS-USERID"
ENTER
ONLIT UserId
.dword WFETCH
EXIT
eword
; H: ( i*n i tbyte1 j tbyte2 tool# -- j*n ) call IIgs toolbox
; tbyte1,2, each bit reflects size of the param, 0=word, 1=long
; tbyte1 = params in, tbyte 2 = params out
; WR=tool# ZR=results types XR+2=results count
; XR=counter,YR=param types (used in loops)
dword dGS_TOOLCALL,"$GS-TOOLCALL"
jsr _popwr ; ( ... i*n i tbyte1 j tbyte2 ) -> tool# get tool #
jsr _popay ; ( ... i*n i tbyte1 j ) -> tbyte2 get results types
sty ZR ; save in ZR and YR
sty YR
sta ZR+2
sta YR+2
jsr _popay ; ( ... i*n i tbyte1 ) -> j get results count
sty XR+2 ; save in XR and XR+2
sty XR
tya ; now make space for results
beq doparms ; if zero, no results expected
l0: pea $0000 ; each param is at least a word
lsr YR+2
ror YR
bcc :+
pea $0000 ; make it a long if carry set
: dec XR
bne l0
doparms: jsr _popyr ; ( ... i*n i ) -> tbyte1 get param types into YR
jsr _popay ; ( ... i*n ) -> i get param count
sty XR
tya
sta f:$2fe
beq docall ; if none, leave stack alone
l1: jsr _popay ; otherwise, pop all the i*n
lsr YR+2 ; get type
ror YR
bcc :+ ; if carry clear, not a long
pha ; if carry set, push high word
: phy ; push low word
dec XR
bne l1
docall: stx WR+2 ; save stack
ldx WR ; Tool #
jsl f:ToolCall
ldx WR+2
sta WR ; result code if error
rol WR+2 ; carry->bit 0 of WR+2
lda XR+2 ; results count
beq done ; if none, do nothing
l2: lda #$0000 ; clear high word
ply ; get low word
lsr ZR+2 ; now see if it's a long
ror ZR
bcc :+ ; nope, no high word to get
pla ; yes, get high word
: jsr _pushay
dec XR+2
bne l2
done: lsr WR+2 ; was there an error?
bcc :+ ; nope, all good
ldy WR ; otherwise get error code
lda #$0000
jmp _throway ; and throw it
: NEXT
eword
dword uTotalMem,"_TOTALMEM"
ENTER
ONLIT 0 ; # params
ONLIT 0 ; Param types
ONLIT 1 ; # of results
ONLIT %1 ; Result types (1=long)
ONLIT $1D02 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uReadBParam,"_READBPARAM"
ENTER
ONLIT 1 ; # params
ONLIT %0 ; Param types
ONLIT 1 ; # of results
ONLIT %0 ; Result types (1=long)
ONLIT $0C03 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uReadTimeHex,"_READTIMEHEX"
ENTER
ONLIT 0 ; # params
ONLIT 0 ; Param types
ONLIT 4 ; # of results
ONLIT %0000 ; Result types (1=long)
ONLIT $0D03 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uReadAsciiTime,"_READASCIITIME"
ENTER
ONLIT 1 ; # params
ONLIT %1 ; Param types
ONLIT 0 ; # of results
ONLIT 0 ; Result types (1=long)
ONLIT $0F03 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uFWEntry,"_FWENTRY"
ENTER
ONLIT 4 ; # params
ONLIT %0000 ; Param types
ONLIT 4 ; # of results
ONLIT %0000 ; Result types (1=long)
ONLIT $2403 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uSysBeep,"_SYSBEEP"
ENTER
ONLIT 0 ; # params
ONLIT 0 ; Param types
ONLIT 0 ; # of results
ONLIT 0 ; Result types (1=long)
ONLIT $2C03 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword uSysFailMgr,"_SYSFAILMGR"
ENTER
ONLIT 2 ; # params
ONLIT %10 ; Param types
ONLIT 0 ; # of results
ONLIT 0 ; Result types (1=long)
ONLIT $1503 ; Tool #
.dword dGS_TOOLCALL
EXIT
eword
dword dP8_CALL,"$P8-CALL"
jsr _popwr ; buffer address (in bank 0)
jsr _popay ; call number
tya
ldy WR
stx WR
jsr _p8_call ; go make the call
ldx WR
tay
beq :+
lda #$0001
jmp _throway
: NEXT
eword
dword dP8_BUFS,"$P8-BUFS"
FCONSTANT IOBufs
eword
dword dP8_nBUFS,"$P8-#BUFS"
FCONSTANT IOBuf_Cnt
eword
dword dP8_PPAD,"$P8-PPAD"
FCONSTANT PPad
eword
dword dP8_RWBUF,"$P8-RWBUF"
FCONSTANT RWBuf
eword
dword dP8_BLKBUF,"$P8-BLKBUF"
FCONSTANT Blk_Buf
eword

85
platforms/W65C816SXB/README.md Normal file
View File

@ -0,0 +1,85 @@
# W65C816SXB
This is a port to WDC's [W65C816SXB](https://wdc65xx.com/boards/w65c816sxb-engineering-development-system/)
development board. To build it, change to the platform directory and run
build.sh. This will output a binary named "forth" that is suitable for placing
in one of the Flash ROM banks of the W65C816SXB at $8000. Andrew Jacob's
[w65c816sxb-hacker](https://github.com/andrew-jacobs/w65c816sxb-hacker) is
suitable for this. Note that OF816 currently uses the USB port as the console
device.
You may also create a completely custom ROM image that replaces the WDC monitor
with OF816, all that is required (assuming you are not going to use interrupts)
is to point the RESET vector to $8000. It may be desirable to point the NMI
vector at a routine that resets the system stack pointer and jumps to
``_Forth_ui``.
While this platform provides the "reference" platform with regards to system
implementation, configuring it and making it work are an advanced topic.
**Note:** None of WDC's tools are used to build OF816.
## Port Features
### Banked ROM Access
The platform words include ``$SXB-READROM`` ( rom_addr dest_addr size -- ).
This word allows copying size bytes from any bank in the ROM into dest_addr.
The rom_addr is an address of the form $bb00xxxx where bb is the bank number
(0-3) and xxxx is the physical address of the memory in bank 0. I.e. the
valid ranges are $00008000-$0000FFFF, $01008000-$0100FFFF, etc.
### FCode/romfs ROM Loader
If FCode support is enabled, the word ``$SXB-ROMLDR`` is included in the
platform words. This encapsulates ``fcode/romloader.fs`` and executing it will
cause the ROM Loader and romfs words to be installed (romfs support may be
disabled, see the source).
The ROM Loader keeps a $100-byte cache of the last ROM page read in order to
reduce the number of bank-switch/copy operations.
Once the ROM Loader and romfs are installed, the following words are available:
#### FCode Loader Words
``$SXB-ROM-FCODE-AT?`` ( rom-addr -- f ) f is true if there is a FCode magic
("MGFC") at the given ROM address. rom-addr must be on a page boundary.
``$SXB-ROM-BYTE-LOAD`` ( rom-addr -- ) evaluate FCode at rom-addr, satisified
by the conditions of ``$SXB-ROM-FCODE-AT?``.
``$SXB-FC-BOOT`` ( -- ) search ROM at $1000-byte alignments for FCode identified
by ``$SXB-ROM-FCODE-AT?`` and evaluate it.
#### romfs Words
romfs words generally follow the ANS Forth File Access word set guidelines,
however they automatically throw non-zero IORs, therefore if the word returns
normally the IOR is always 0. Consult the ANS standard for complete description
of stack items.
``INCLUDE`` ( <>"name" -- ... ) parse name and perform the function of INCLUDED.
``INCLUDED`` ( c-addr u -- ... ) evaluate romfs file named by c-addr u.
``OPEN-FILE`` ( c-addr u fam -- fileid 0 ) open romfs file, fam is discarded,
access is always read-only.
``READ-LINE`` ( c-addr u fileid - u2 f 0 ) read a line up to u bytes from file.
``READ-FILE`` ( c-addr u fileid - u2 0 ) read up to u bytes from file.
``FILE-POSITION`` ( fid -- u ) return read position in file
``CLOSE-FILE`` ( fileid -- 0 ) close romfs file
``ROMFS-LIST`` ( -- ) list files in romfs.
``$SXB-ROM-ROMFS-AT?`` ( rom-addr -- f ) f is true if there is a ROMFS magic
("MGFS") at the given ROM address. rom-addr must be on a page boundary.
``$SXB-ROMFS`` ( -- u ) VALUE, zero if no romfs was found, otherwise contains
the ROM address of the romfs.

16
platforms/W65C816SXB/W65C816SXB.l Normal file
View File

@ -0,0 +1,16 @@
FEATURES {
STARTADDRESS: default = $8000;
}
MEMORY {
ROM: start = $8000, size = $7800, file = %O;
ZP: start = $0000, size = $100;
}
SEGMENTS {
FStartup: load=ROM,type=ro;
FSystem: load=ROM, type=ro;
FCode: load=ROM, type=ro, optional=yes;
ZEROPAGE: load=ZP, type=bss;
}

51
platforms/W65C816SXB/W65C816SXB.s Normal file
View File

@ -0,0 +1,51 @@
.p816
.a16
.i16
.include "macros.inc"
.import _Forth_initialize
.import _Forth_ui
.import _system_interface
.pushseg
.segment "FStartup"
.proc startup
clc
xce
rep #SHORT_A|SHORT_I
lda #$0300 ; direct page for Forth
tcd
.if 1 ; SXB as it comes
lda #.hiword($7000) ; top of dictionary memory
pha
lda #.loword($7000)
pha
lda #.hiword($0A00) ; bottom of dictionary
pha
lda #.loword($0A00)
pha
.else ; special SXB with RAM expansion
lda #.hiword($020000) ; top of dictionary memory
pha
lda #.loword($020000)
pha
lda #.hiword($010000) ; bottom of dictionary
pha
lda #.loword($010000)
pha
.endif
lda #$0300 ; first usable stack cell (relative to direct page)
pha
lda #$0100 ; last usable stack cell+1 (relative to direct page)
pha
lda #$09FF ; return stack first usable byte
pha
lda #.hiword(_system_interface)
pha
lda #.loword(_system_interface)
pha
jsl _Forth_initialize
jsl _Forth_ui
brk
.byte $00
.endproc
.popseg

9
platforms/W65C816SXB/build.sh Executable file
View File

@ -0,0 +1,9 @@
#!/bin/bash
set -e -x
toke fcode/romloader.fs
ruby mkromfs.rb romfs fs/*
ca65 -I ../../inc W65C816SXB.s -l W65C816SXB.lst
../../build.sh W65C816SXB
ld65 -C W65C816SXB.l -S 0x8000 W65C816SXB.o ../../forth.o -m forth.map -o forth
ls -l forth

53
platforms/W65C816SXB/fcode/hardware.fs Normal file
View File

@ -0,0 +1,53 @@
\ W65C816SXB hardware support
start1 hex
." W65C816SXB hardware support by M.G. "
external
7F80 value ACIA
7FA0 value PIA
7FC0 value VIA1
7FE0 value VIA2
struct
0 field ACIA>RXD
1 field ACIA>TXD
1 field ACIA>SR
1 field ACIA>CMD
1 field ACIA>CTL
endstruct drop
struct
0 field PIA>PIA
1 field PIA>DDRA
1 field PIA>CRA
0 field PIA>PIB
1 field PIA>DDRB
1 field PIA>CRB
endstruct drop
struct
0 field VIA>ORB
1 field VIA>IRB
0 field VIA>ORA
1 field VIA>IRA
1 field VIA>DDRB
1 field VIA>DDRA
2 field VIA>T1C
2 field VIA>T1L
2 field VIA>T2C
1 field VIA>SR
1 field VIA>ACR
1 field VIA>PCR
1 field VIA>IFR
1 field VIA>IER
0 field VIA>ORAN
1 field VIA>IRAN
endstruct drop
." loaded!"
fcode-end

350
platforms/W65C816SXB/fcode/romloader.fs Normal file
View File

@ -0,0 +1,350 @@
\ W65C816SXB ROM loader. Itself in FCode, this defines some words to bootstrap
\ any FCode and files in the SXB's flash ROM.
\ This provides two facilities: FCode loader, and romfs.
\ romfs provides a simple filesystem of up to 32K (one bank of ROM) in the SXB for
\ files. Basic ANSI-ish functions to open/read/close the files are provided
\ as well as include and included. romfs was inspired by SLOF's romfs.
\ romfs may be omitted during tokenization by defining the commad-line symbol no-romfs
\ i.e. adding -d no-romfs to the toke command line, this saves more than 1K of output
\ in the tokenized FCode.
\ Note that the SXB-specific word $SXB-READROM takes a virtual address of the form
\ $bbaaaaaa where bb is the ROM bank to select, and the address is then used to read it
\ For practical purposes to read the ROM the addresses are restricted to:
\ $00008000-$0000FFFF - bank 0, $01008000-$0100FFFF - bank 1,
\ $02008000-$0200FFFF - bank 2, $03008000-$0300FFFF - bank 3.
start1 hex
." W65C816SXB ROM loader by M.G. ... "
headers
headerless
\ Stuff we need to get to that isn't supported by FCode
defer $sxb-readrom
s" $sxb-readrom" $find 0= if ." no $SXB-READROM" abort then to $sxb-readrom
[ifndef] no-romfs
defer -trailing
s" -trailing" $find drop to -trailing
defer parse-word
s" parse-word" $find drop to parse-word
: 2w@ dup w@ swap wa1+ w@ ;
\ temp vars for file I/O, headerless to save space
\ $fileno is used for susequent conditionals to compile remaining romfs code
0 value $fileno
0 value $bufsz
0 value $buffer
0 value $incbuffer
[endif]
headers
\ a $100-byte page buffer is provided to avoid slow reads of the ROM to a certain extent
fffffffff value $sxb-readrom-page
0 value $sxb-readrom-buf
[ifexist] $fileno
0 value $sxb-romfs-filebuf
0 value $sxb-romfs-files
0 value $sxb-romfs-tab
[endif]
\ fetch a page to the page buffer, allocating it if necessary, and doing nothing if
\ it's already in the page buffer
: $sxb-rom-fetchpage ( v-addr -- v-addr )
$sxb-readrom-buf 0= if
100 alloc-mem to $sxb-readrom-buf
ffffffff to $sxb-readrom-page ( invalid page number )
then
dup 8 >> $sxb-readrom-page <> if
dup ffffff00 and $sxb-readrom-buf 100 $sxb-readrom
dup 8 >> to $sxb-readrom-page
then
;
\ Byte read function for the ROM, used to execute FCode.
: $sxb-rom-rb@ ( v-addr -- byte )
$sxb-rom-fetchpage ff and $sxb-readrom-buf + c@
;
\ Free the page buffer to return memory to the user
: $sxb-readrom-free ( -- )
$sxb-readrom-buf if
$sxb-readrom-buf 100 free-mem
then
0 to $sxb-readrom-buf
ffffffff to $sxb-readrom-page
;
\ Magic test for FCode
: $$fcode-at? ( v-addr -- f )
$sxb-rom-fetchpage ff and $sxb-readrom-buf + @ 4346474D =
;
[ifexist] $fileno
\ Magit test for romfs
: $$romfs-at? ( v-addr -- f )
$sxb-rom-fetchpage ff and $sxb-readrom-buf + @ 5346474D =
;
[endif]
external
[ifexist] $fileno
\ Holds location of discovered romfs
0 value $sxb-romfs
[endif]
\ see if there is FCode in the SXB ROM at v-addr.
: $sxb-rom-fcode-at? ( v-addr -- f )
$$fcode-at? $sxb-readrom-free
;
[ifexist] $fileno
\ see if there is romfs in the SXB ROM at v-addr.
: $sxb-rom-romfs-at? ( v-addr -- f )
$$romfs-at? $sxb-readrom-free
;
[endif]
\ byte-load FCode in the SXB ROM.
: $sxb-rom-byte-load ( v-addr -- )
dup $$fcode-at? if
cell+ ['] $sxb-rom-rb@ ['] byte-load catch
$sxb-readrom-free
dup if
nip nip
then
throw
else
." no FCode at " . true abort
then
;
headers
\ Scan a bank for FCode and execute any that is found
: $sxb-fc-boot-bank ( bank -- )
1000000 *
ffff 8000 do dup i + dup $$fcode-at? if
$sxb-rom-byte-load
else
drop
then
1000 +loop
drop
;
[ifexist] $fileno
\ scan a bank for romfs and update $sxb-romfs if found
: $romfs-find-bank ( bank -- )
1000000 *
ffff 8000 do dup i + dup $$romfs-at? if
to $sxb-romfs leave
else
drop
then
1000 +loop
drop
;
\ return address of romfs or throw exception
: $sxb-romfs? ( -- addr )
$sxb-romfs ?dup 0= if d# -37 throw then
;
\ Normalize file ID and make sure it is valid
: romfs-file? ( u1 -- u2 / u2 = normalized file ID )
ffff and dup $sxb-romfs-files u>= if d# -38 throw then
;
\ Get file name of file in romfs
: romfs-file ( u -- c-addr u2 )
romfs-file? $sxb-romfs?
$sxb-rom-fetchpage drop $sxb-readrom-buf cell+ char+ swap 4 << + c -trailing
;
\ Return info about a romfs file
: romfs-finfo ( -- offset length )
romfs-file drop c + 2w@
;
\ Find a file in the romfs, return file number if we find it
: romfs-ffind ( c-addr u -- u2 true | false )
-1 -rot $sxb-romfs-files 0 ?do
2dup i romfs-file 2 pick = if
\ lengths equal
swap comp 0= if
i -rot >r >r swap drop r> r>
then
else
\ lengths unequal
3drop
then
loop
2drop
dup 0< if
drop false
else
true
then
;
\ Get ROMfs table entry for file number
: $romfs-t# ( file# -- addr )
2* cells $sxb-romfs-tab +
;
\ "open" a romfs file
\ Set up table entry for the file with current (start) and end addresses.
: $romfs-open ( u -- )
>r r@ romfs-finfo over + $sxb-romfs + swap $sxb-romfs + swap r> $romfs-t# 2!
;
\ "close" a romfs file. Set current address to end address
: $romfs-close ( u -- )
$romfs-t# >r r@ 2@ swap drop dup r> 2!
$sxb-readrom-free
;
\ Check if we hit EOF in open romfs file
: $romfs-eof? ( u -- f )
$romfs-t# 2@ u>=
;
\ Byte read routine for romfs
: $romfs-rb@ ( u -- byte )
$romfs-t# dup >r @ dup 1+ r> ! $sxb-rom-rb@
;
\ See if we hit a line-ending char
: is-eol?
case
0d of true endof \ CR
0a of true endof \ LF
>r false r>
endcase
;
\ Locate a romfs in the SXB ROM, updating $sxb-romfs and $sxb-romfs-files if found
\ and allocating the access table
: $romfs-find ( -- )
4 1 do $sxb-romfs if leave else i $romfs-find-bank then loop
$sxb-romfs if
$sxb-romfs $sxb-rom-fetchpage drop $sxb-readrom-buf cell+ c@ dup to $sxb-romfs-files
2* cells dup alloc-mem dup to $sxb-romfs-tab swap erase
then
$sxb-readrom-free
;
[endif]
external
\ Find and execute all FCode in ROM at $1000-aligned addresses
: $sxb-fc-boot
4 1 do i $sxb-fc-boot-bank loop
$sxb-readrom-free
;
[ifexist] $fileno
\ List files in romfs
: romfs-list
$sxb-romfs-files 0 ?do
i romfs-file type cr
loop
$sxb-readrom-free
;
\ open file in romfs
: open-file ( c-addr u fam -- fileid 0 )
drop
romfs-ffind if
dup 10000 or swap $romfs-open 0
else
d# -69 throw
endif
;
\ report position in open file
: file-position ( fid -- u )
romfs-file? $romfs-t# 2@ swap -
;
\ close romfs file
: close-file ( fileid -- 0 )
romfs-file? $romfs-close 0
$sxb-readrom-free
;
\ read open romfs file
: read-file ( c-addr u fileid - u2 0 )
romfs-file? to $fileno to $bufsz to $buffer
0
$bufsz 0 ?do
$fileno $romfs-eof? if leave then
$fileno $romfs-rb@
over $buffer + c! 1+
loop
0
;
\ read a line from open romfs file
: read-line ( c-addr u fileid - u2 f 0 )
romfs-file? to $fileno to $bufsz to $buffer
0
$bufsz 0 ?do
$fileno $romfs-eof? if leave then
$fileno $romfs-rb@
dup is-eol? if drop leave then
over $buffer + c! 1+
loop
$fileno $romfs-eof? 0= 0
;
headers
\ read and evaluate each line of file in romfs describe in incbuf
\ incbuf is a buffer 1 cell+80 bytes long, with the file id in the cell
: $inc ( incbuf -- )
$incbuffer ?dup 0= if d# -9 throw then
begin
>r r@ cell+ 80 r@ @
read-line 2drop
r@ cell+ swap eval
r> dup @ romfs-file?
$romfs-eof? until
drop
;
external
\ allocate a buffer and evaulate the given file
: included ( c-addr u -- )
0 open-file drop
$incbuffer >r 80 cell+ alloc-mem dup to $incbuffer !
['] $inc catch r> swap >r $incbuffer swap to $incbuffer
dup @ close-file drop 80 cell+ free-mem
r> throw
;
\ parse name and perform the function of included
: include ( " name " -- )
parse-word included
;
$romfs-find
[endif]
." loaded!" cr
[ifexist] $fileno
$sxb-romfs ?dup if ." ROMfs at " u. cr then
[endif]
fcode-end

26
platforms/W65C816SXB/fs/message.fs Normal file
View File

@ -0,0 +1,26 @@
base @ decimal
: message ( n -- 0|n )
dup case
-3 of s" Stack o/f" endof
-9 of s" Invalid address" endof
-11 of s" Numeric o/f" endof
-12 of s" Argument type m/m" endof
-14 of s" Compile-only word" endof
-18 of s" String o/f" endof
-21 of s" Unsupported operation" endof
-22 of s" Control structure m/m" endof
-24 of s" Invalid numeric arg" endof
-31 of s" Can't >BODY" endof
-37 of s" I/O error" endof
-38 of s" File not found" endof
-49 of s" Search-order o/f" endof
-50 of s" Search-order u/f" endof
-59 of s" Can't ALLOC-MEM" endof
-60 of s" Can't FREE-MEM" endof
-69 of s" Can't open file" endof
-256 of s" Undefined Fcode#" endof
>r 0 0 r>
endcase
?dup if type drop 0 else drop then
;
base !

34
platforms/W65C816SXB/mkromfs.rb Executable file
View File

@ -0,0 +1,34 @@
#!/usr/bin/ruby
def usage
abort("Usage: #{$0} <outfile> <infile> [<infile> ...]")
end
def set_file_header(data, file_no, name, offset, size)
f_name = file_no*16+5
f_offs = f_name+12
f_size = f_offs+2
name.bytes.each_with_index {|b, i| data[f_name+i] = b}
data[f_offs] = offset & 0xFF
data[f_offs+1] = (offset >> 8) & 0xFF
data[f_size] = size & 0xFF
data[f_size+1] = (size >> 8) & 0xFF
end
outfile = ARGV.shift || usage
usage if ARGV.empty?
abort("Too many files (>15)") if ARGV.count > 15
out_bytes = [0x4D, 0x47, 0x46, 0x53]
out_bytes += [ARGV.count] # file count
out_bytes += (([0x20] * 12)+([0x00]*4)) * ARGV.count # header for each file
ARGV.each_with_index do |file, i|
data = File.read(file).bytes
set_file_header(out_bytes, i, File.basename(file)[0,12], out_bytes.count, data.count)
out_bytes += data
end
File.write(outfile, out_bytes.map(&:chr).join)

1
platforms/W65C816SXB/platform-config.inc Normal file
View File

@ -0,0 +1 @@

309
platforms/W65C816SXB/platform-lib.s Normal file
View File

@ -0,0 +1,309 @@
; Platform support library for WDC W65C816SXB
;
; This serves as a "reference" implementation.
;
; This file should define any equates that are platform specific, and may be used to
; define the system interface functions if it is not supplied elsewhere.
;
; Generally the system interface is used for console I/O
; and other such things. The function code is given in the A register, the Y register
; has the Forth stack depth, and X is the Forth stack pointer vs the direct page.
; THE X REGISTER MUST REFLECT PROPER FORTH STACK POINTER UPON RETURN!
;
; The interface function is called with the Forth direct page and return stack in effect.
; Function codes $0000-$7FFF are reserved to be defined for use by Forth. Codes $8000-
; $FFFF may be used by the system implementator for system-specific functions.
;
; The system interface must implement functions marked as mandatory.
; System interface functions shall RTL with the expected stack effects, AY=0, and
; carry clear if successful; or shall RTL with a code for THROW in AY and carry set on
; failure. A safe throw code for console I/O is -21 (unsupported operation).
;
; Stack cells are 2 words/4 bytes/32 bits, and the stack pointer points to the top of
; the stack. If the system interface is defined here, the stack manipulation functions
; defined in interpreter.s may be used. If defined elsewhere, you are on your own for
; ensuring correct operation on the stack.
;
; The system interface functions may use the direct page ZR bytes $00-$03, if they need
; more than that they can use something reserved elsewhere via long addressing or
; by temporarily changing the direct page.
;
; Here are the function codes, expected stack results, and descriptions
;
; $0000 ( -- ) pre initialize platform - called before Forth initialization, to be used
; for initialization that must take place before Forth initialization.
; $0001 ( -- ) post initialize platform - called after Forth initialization, to be used
; for initialization that must take place after Forth initialization.
; $0002 ( char -- ) emit a character to the console output. This function should
; implement the control sequences described in IEEE 1275-1994 (a subset of the
; ANSI terminal standard). For serial devices, this may be assumed.
; $0003 ( -- f ) f is true if the console input has a character waiting
; $0004 ( -- char ) read a character from the console (blocking)
; $0005 ( -- addr ) return pointer to list of FCode modules to evaluate. If pointer is
; 0, none are evaluated. List should be 32-bit pointers ending in 0.
; this is never called if FCode support is not included. When this is implemented
; the system will trust that there is FCode there and not look for a signature.
; $0006 ( -- ) perform RESET-ALL, restart the system as if reset button was pushed
cpu_clk = 8000000
.enum ACIA
RXD
SR
CMD
CTL
TXD = RXD
.endenum
ACIA1 = $7F80
.enum PIA
PIA
CRA
PIB
CRB
DDRA = PIA
DDRB = PIB
.endenum
PIA1 = $7FA0
.enum VIA
ORB
ORA
DDRB
DDRA
T1C_L
T1C_H
T1L_L
T1L_H
T2C_L
T2C_H
SR
ACR
PCR
IFR
IER
ORA2
IRB = ORB
IRA = ORA
.endenum
VIA1 = $7FC0
VIA2 = $7FE0
.proc _system_interface
;wdm 3
phx
asl
tax
jmp (table,x)
table: .addr _sf_pre_init
.addr _sf_post_init
.addr _sf_emit
.addr _sf_keyq
.addr _sf_key
.addr _sf_fcode
.addr _sf_reset_all
.endproc
.export _system_interface
.proc _sf_success
lda #$0000
tay
clc
rtl
.endproc
.proc _sf_fail
ldy #.loword(-21)
lda #.hiword(-21)
sec
rtl
.endproc
.proc _sf_pre_init
.if 1
plx
jmp _sf_success ; assume WDC monitor already did it
.else
; set up TIDE interface, the same way WDC does it
php
sep #SHORT_A|SHORT_I
.a8
.i8
lda #$00
sta VIA2+VIA::ACR
lda #$00
sta VIA2+VIA::PCR
lda #%00011000 ; b3 = TUSB_RDB; b4 = ???
sta VIA2+VIA::ORB
lda #%00011100 ; set PB2, PB3, PB4 as outputs
sta VIA2+VIA::DDRB
lda #$00
sta VIA2+VIA::DDRA
lda VIA2+VIA::IRB
pha
and #%11101111 ; b4 = ???
sta VIA2+VIA::ORB
ldx #$5d
jsr wait
pla
sta VIA2+VIA::ORB
lda #%00100000 ; b5 = TUSB_PWRENB
: bit VIA2+VIA::IRB ; wait for USB configuration
bne :-
plp
plx
jmp _sf_success
wait: phx ; note 8-bit mode!
ldx #$00
: dex
bne :-
plx
dex
bne wait
rts
.a16
.i16
.endif
.endproc
.proc _sf_post_init
plx
jmp _sf_success
.endproc
.proc _sf_emit
plx
jsr _popay
phx
php
sep #SHORT_A|SHORT_I
.a8
.i8
tya
ldx #$00 ; ensure VIA2 DDR A is set up for input
stx VIA2+VIA::DDRA
sta VIA2+VIA::ORA ; set output byte to be sent
lda #%00000001 ; b0 = TUSB_TXEB
: bit VIA2+VIA::IRB ; wait for FT245RL to be ready to transmit
bne :-
lda VIA2+VIA::IRB
and #%11111011 ; b2 = TUSB_WR
tax
ora #%00000100
sta VIA2+VIA::ORB ; ensure FT245RL WR high
lda #$ff ; set up DDR A for output
sta VIA2+VIA::DDRA ; to present byte to send
nop ; delay a few cycles
nop
stx VIA2+VIA::ORB ; strobe FT245RL WR low
lda VIA2+VIA::IRA ; ???
ldx #$00
stx VIA2+VIA::DDRA ; switch DDR A back to input
plp
.a16
.i16
plx
jmp _sf_success
.endproc
.proc _sf_keyq
lda #$00
tay ; anticipate false
php
sep #SHORT_A
.a8
sta VIA2+VIA::DDRA
lda #%00000010
bit VIA2+VIA::IRB
bne :+
dey ; from $0000 to $FFFF
: plp
.a16
tya
plx
jsr _pushay
jmp _sf_success
.endproc
.proc _sf_key
php
tay
sep #SHORT_A|SHORT_I
.a8
.i8
lda #$00
sta VIA2+VIA::DDRA ; Ensure VIA2 DDR A is set up for input
lda #%00000010 ; b1 = TUSB_RXFB
: bit VIA2+VIA::IRB ; wait for FT245RL to have data & be ready
bne :-
lda VIA2+VIA::IRB
ora #%00001000 ;b3 = TUSB_RDB
tax
and #%11110111
sta VIA2+VIA::ORB ; strobe FT245RL RD# low
nop ;delay some cycles
nop
nop
nop
ldy VIA2+VIA::IRA ; receive byte
stx VIA2+VIA::ORB ; strobe FT245RL RD# high
plp
.a16
.i16
lda #$0000
plx
jsr _pushay
jmp _sf_success
.endproc
.proc _sf_fcode ; none for now
lda #$0000
tay
plx
jsr _pushay
jmp _sf_success
.endproc
; SXB really can't do this when ROM is banked out. Maybe restart Forth instead?
.proc _sf_reset_all
plx
jmp _sf_fail
.endproc
; Read ROM, virtual address $bb00xxxx in WR, length in XR, destination in YR
; where bb is the ROM bank number (0-3) and xxxx is the physical address in the ROM.
; This routine will be moved into RAM in order to read the contents of the ROM.
.proc _sxb_readrom
php ; save register size & interrupt state
sei ; disable IRQs since we are switching the ROM
sep #SHORT_A
.a8
lda VIA2+VIA::PCR ; save existing PCR
pha
lda WR+3 ; get bank #
ror
php
ror
lda #$00
bcs :+
ora #%11000000
: plp
bcs :+
ora #%00001100
: sta VIA2+VIA::PCR
ldy XR
lp: dey
bmi done
lda [WR],y
sta [YR],y
bra lp
done: pla
sta VIA2+VIA::PCR ; restore PCR
plp ; restore register size & interrupt state
.a16
rtl ; note long return
.endproc

56
platforms/W65C816SXB/platform-words.s Normal file
View File

@ -0,0 +1,56 @@
; Platform support dictionary words for WDC W65C816SXB
;
; This file serves as a "reference implementation" for how to do this.
; ROM read. This will read from the SXB's flash ROM, from any bank.
; Requires memmgr.s to have the memory move routines and platform-lib.s to have
; _sxb_readrom
; Since we expect the Forth interpreter to be in the ROM, this works by copying the
; _sxb_readrom routine into allocated RAM and executing it from there using RTL tricks.
; H: ( rom_addr dest_addr size ) rom_addr is a 'virtual' address of bb00xxxx
dword SXB_READROM,"$SXB-READROM"
ENTER
ONLIT _sxb_readrom ; ( -- a-addr )
ONLIT .sizeof(_sxb_readrom) ; ( a-addr -- a-addr u )
.dword DUP ; ( ... a-addr u u' )
.dword ALLOC ; ( ... a-addr1 u a-addr2 )
.dword DUP ; ( ... a-addr1 u a-addr2 a-addr2' )
.dword PtoR ; ( ... a-addr1 u a-addr2 )
.dword SWAP ; ( ... a-addr1 a-addr2 u )
.dword MOVE ; ( a-addr1 a-addr2 u -- ) move code into place
.dword RCOPY ; ( -- a-addr2' )
CODE
jsr _popay ; set up a JML to allocated routine
sty ZR+1
sep #SHORT_A
.a8
sta ZR+3
lda #opJML
sta ZR
rep #SHORT_A
.a16
jsr _popxr ; pop read arguments from the stack
jsr _popyr ; into the correct working registers
jsr _popwr
jsl f:_callzr ; and call the allocated routine
ENTER
.dword RtoP ; pull allocation off stack
ONLIT .sizeof(_sxb_readrom)
.dword FREE ; and free it
EXIT
eword
dword dCPU_HZ,"$CPU_HZ"
FCONSTANT cpu_clk
eword
.if include_fcode ; SXB stuff, should do different
dword SXB_ROMLDR,"$SXB-ROMLDR"
ENTER
ONLIT :+
.dword ONE
.dword BYTE_LOAD
EXIT
: PLATFORM_INCBIN "fcode/romloader.fc"
eword
.endif