mirror of
https://github.com/mgcaret/of816.git
synced 2024-06-14 05:29:31 +00:00
initial full commit
This commit is contained in:
parent
3721765c27
commit
50ae7f1361
24
LICENSE
Normal file
24
LICENSE
Normal 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
41
README.md
Normal 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
158
asm/compiler.s
Normal 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
58
asm/env-dictionary.s
Normal 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
1372
asm/fcode.s
Normal file
File diff suppressed because it is too large
Load Diff
6914
asm/forth-dictionary.s
Normal file
6914
asm/forth-dictionary.s
Normal file
File diff suppressed because it is too large
Load Diff
1078
asm/interpreter.s
Normal file
1078
asm/interpreter.s
Normal file
File diff suppressed because it is too large
Load Diff
384
asm/mathlib.s
Normal file
384
asm/mathlib.s
Normal 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
626
asm/memmgr.s
Normal 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
207
asm/system.s
Normal 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
11
build.sh
Executable 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
84
config.inc
Normal 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
228
docs/getting_started.md
Normal 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
262
docs/internals.md
Normal 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
167
docs/porting.md
Normal 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
72
fcode-modules/editor.fs
Normal 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
12
fcode-modules/makemod.sh
Executable 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
5
fcode-modules/test.fs
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
start1
|
||||||
|
." This is a test!" cr
|
||||||
|
fcode-end
|
||||||
|
|
||||||
|
|
29
forth.s
Normal file
29
forth.s
Normal 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
52
inc/equates.inc
Normal 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
396
inc/macros.inc
Normal 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
15
platforms/IIgs/IIgs.l
Normal 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
203
platforms/IIgs/IIgs.s
Normal 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
124
platforms/IIgs/README.md
Normal 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
9
platforms/IIgs/build.sh
Executable 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
3
platforms/IIgs/platform-config.inc
Normal 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
108
platforms/IIgs/platform-include.inc
Normal 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
594
platforms/IIgs/platform-lib.s
Normal 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
207
platforms/IIgs/platform-words.s
Normal 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
85
platforms/W65C816SXB/README.md
Normal 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
16
platforms/W65C816SXB/W65C816SXB.l
Normal 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
51
platforms/W65C816SXB/W65C816SXB.s
Normal 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
9
platforms/W65C816SXB/build.sh
Executable 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
53
platforms/W65C816SXB/fcode/hardware.fs
Normal 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
350
platforms/W65C816SXB/fcode/romloader.fs
Normal 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
26
platforms/W65C816SXB/fs/message.fs
Normal 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
34
platforms/W65C816SXB/mkromfs.rb
Executable 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
1
platforms/W65C816SXB/platform-config.inc
Normal file
|
@ -0,0 +1 @@
|
||||||
|
|
309
platforms/W65C816SXB/platform-lib.s
Normal file
309
platforms/W65C816SXB/platform-lib.s
Normal 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
56
platforms/W65C816SXB/platform-words.s
Normal 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
|
Loading…
Reference in New Issue
Block a user