mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
Carsten Strotmann
GitHub
commit
c03d6d0c82
|
|
@ -24,7 +24,7 @@ update: $(vf_blk_fth_files) $(vf_fth_files_petscii)
|
|||
|
||||
|
||||
clean:
|
||||
rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log
|
||||
rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log tmp/*
|
||||
rm -f *.log *.result *.golden
|
||||
rm -f cbmfiles/c??-testbase
|
||||
rm -f disks/scratch.d64 emulator/sdcard.img
|
||||
|
|
@ -58,7 +58,7 @@ run-testbase16: emulator/testbase16.T64
|
|||
|
||||
# Targetcompiler targets
|
||||
|
||||
cbmfiles/tcbase: emulator/c64-vf-390.T64 emulator/build-tcbase.sh \
|
||||
cbmfiles/tcbase: emulator/v4th-c64-4tc.T64 emulator/build-tcbase.sh \
|
||||
disks/tc38q.d64 disks/file-words.d64 cbmfiles/tc-base.fth
|
||||
emulator/build-tcbase.sh
|
||||
|
||||
|
|
@ -132,7 +132,7 @@ test-v4th-c16-.log: emulator/v4th-c16-.T64
|
|||
test-v4th-x16.log: cbmfiles/v4th-x16 emulator/sdcard.img
|
||||
rm -f cbmfiles/test.log
|
||||
emulator/run-in-x16emu.sh v4th-x16 \
|
||||
"INCLUDE RUN-STD-TESTS.FTH\\X0D1234567890\\X0D"
|
||||
"include run-std-tests.fth\n1234567890\n"
|
||||
mcopy -i emulator/sdcard.img ::TEST.LOG cbmfiles/test.log
|
||||
petscii2ascii cbmfiles/test.log $@
|
||||
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
6502/C64/cbmfiles/v4th-c64-4tc
Normal file
BIN
6502/C64/cbmfiles/v4th-c64-4tc
Normal file
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -14,4 +14,4 @@ keybuf="3 drive 20 load\n3 drive 10 load\nsave\n\
|
|||
savesystem tcbase\ndos s0:notdone\n"
|
||||
|
||||
DISK10=tc38q DISK11=file-words "${emulatordir}/run-in-vice.sh" \
|
||||
"c64-vf-390" "${keybuf}"
|
||||
"v4th-c64-4tc" "${keybuf}"
|
||||
|
|
|
|||
|
|
@ -5,9 +5,10 @@ emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")"
|
|||
basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
|
||||
cbmfilesdir="${basedir}/cbmfiles"
|
||||
sdcard="${emulatordir}/sdcard.img"
|
||||
x16script="${basedir}/tmp/x16script"
|
||||
|
||||
mformat -i "${sdcard}" -F
|
||||
for asciifile in $(cd "${cbmfilesdir}" && ls *.fth *fr)
|
||||
for asciifile in $(cd "${cbmfilesdir}" && ls)
|
||||
do
|
||||
# Convert filename to PETSCII, remove trailing CR.
|
||||
petsciifile="$(echo ${asciifile} | ascii2petscii - |tr -d '\r')"
|
||||
|
|
@ -20,13 +21,18 @@ then
|
|||
autostart="-prg ${cbmfilesdir}/${1} -run"
|
||||
fi
|
||||
|
||||
keybuf=""
|
||||
script=""
|
||||
warp=""
|
||||
scale=""
|
||||
debug=""
|
||||
if [ -n "$2" ]
|
||||
then
|
||||
keybuf="${2}"
|
||||
test -d tmp || mkdir tmp
|
||||
rm -f "${x16script}".*
|
||||
echo "load\"${1}\"\nrun\n${2}" | sed 's/\\n/\n/g' > "${x16script}".ascii
|
||||
ascii2petscii "${x16script}.ascii" "${x16script}.petscii"
|
||||
script="-bas ${x16script}.petscii"
|
||||
autostart=""
|
||||
mcopy -i "${sdcard}" "${emulatordir}/notdone" "::NOTDONE"
|
||||
warp="-warp"
|
||||
else
|
||||
|
|
@ -39,13 +45,13 @@ x16emu \
|
|||
-keymap de \
|
||||
-sdcard "${sdcard}" \
|
||||
$autostart \
|
||||
-keybuf "$keybuf" \
|
||||
$script \
|
||||
$warp \
|
||||
$scale \
|
||||
$debug \
|
||||
&
|
||||
|
||||
if [ -n "$keybuf" ]
|
||||
if [ -n "$script" ]
|
||||
then
|
||||
while mtype -i "${sdcard}" "::NOTDONE" > /dev/null
|
||||
do sleep 1
|
||||
|
|
|
|||
15
6502/C64/emulator/update-v4th-4tc.sh
Executable file
15
6502/C64/emulator/update-v4th-4tc.sh
Executable file
|
|
@ -0,0 +1,15 @@
|
|||
#!/bin/bash
|
||||
set -e
|
||||
|
||||
# Script to update the base binary on which the target compiler
|
||||
# is run.
|
||||
|
||||
# The updating of v4th-c64-4tc from the newly built binaries
|
||||
# is intentionally not automatically via Makefile, to ensure a
|
||||
# certain stability for the target compiler.
|
||||
|
||||
emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")"
|
||||
basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
|
||||
cbmfilesdir="${basedir}/cbmfiles"
|
||||
|
||||
cp "${cbmfilesdir}/v4thblk-c64" "${cbmfilesdir}/v4th-c64-4tc"
|
||||
11
6502/C64/src/notmpheap.fth
Normal file
11
6502/C64/src/notmpheap.fth
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
\ When no tmpheap mechanism is needed, i.e. all temporary names
|
||||
\ of a project fit onto the regular heap at once, then this zero-cost
|
||||
\ implementation can be used which directs all tmpheap definitions
|
||||
\ to the regular heap.
|
||||
|
||||
' | alias ||
|
||||
' |on alias ||on
|
||||
' |off alias ||off
|
||||
|
||||
' noop alias tmpclear
|
||||
59
6502/C64/src/tmpheap.fth
Normal file
59
6502/C64/src/tmpheap.fth
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
|
||||
\ This is the reference implementation of tmpheap which allocates
|
||||
\ the tmpheap on the regular heap and moves definitons prefixed
|
||||
\ with || or within a ||on to ||off range onto the tmpheap.
|
||||
\ tmpclear will remove all words on the tmpheap, wheras regular clear
|
||||
\ will remove all words on tmpheap and heap together.
|
||||
|
||||
\ Before the first use of ||, the tmpheap size in bytes must be
|
||||
\ set with mk-tmp-heap ( size -- )
|
||||
|
||||
User tmpheap[
|
||||
User tmpheap>
|
||||
User ]tmpheap
|
||||
|
||||
: reset-tmp-heap ( -- )
|
||||
up@ dup ]tmpheap ! dup tmpheap> ! tmpheap[ ! ;
|
||||
|
||||
reset-tmp-heap
|
||||
' reset-tmp-heap is custom-remove
|
||||
|
||||
: mk-tmp-heap ( size -- )
|
||||
heap dup ]tmpheap ! tmpheap> ! hallot heap tmpheap[ ! ;
|
||||
|
||||
: tmp-hallot ( size -- addr )
|
||||
tmpheap> @ swap -
|
||||
dup tmpheap[ @ u< abort" tmp heap overflow"
|
||||
dup tmpheap> ! ;
|
||||
|
||||
| : tmp-heapmove ( from from size -- from offset )
|
||||
dup tmp-hallot swap cmove
|
||||
tmpheap> @ over - ;
|
||||
|
||||
| : tmp-heapmove1x ( from size -- from offset )
|
||||
tmp-heapmove ?heapmovetx off ;
|
||||
|
||||
: || ['] tmp-heapmove1x ?heapmovetx ! ;
|
||||
: ||on ['] tmp-heapmove ?heapmovetx ! ;
|
||||
: ||off ?heapmovetx off ;
|
||||
|
||||
|
||||
| : remove-tmp-words-in-voc ( voc -- )
|
||||
BEGIN dup @ ?dup WHILE ( thread next-in-thread )
|
||||
dup tmpheap[ @ ]tmpheap @ uwithin IF ( thread next-in-thread )
|
||||
@ ?dup IF ( thread next-next-in-thread ) over !
|
||||
ELSE ( thread ) off exit THEN
|
||||
ELSE ( thread next-in-thread ) nip
|
||||
THEN
|
||||
REPEAT drop ;
|
||||
|
||||
| : remove-tmp-words ( -- )
|
||||
voc-link BEGIN @ ?dup
|
||||
WHILE dup 4 - remove-tmp-words-in-voc REPEAT ;
|
||||
|
||||
: tmpclear ( -- )
|
||||
remove-tmp-words
|
||||
\ Uncomment the following line to help determine the ideal tmpheap
|
||||
\ size for your project.
|
||||
\ tmpheap> @ tmpheap[ @ - cr u. ." spare tmpheap bytes"
|
||||
]tmpheap @ tmpheap> ! last off ;
|
||||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
(C64 02 )
|
||||
(C16 02 )
|
||||
(X16 $30 )
|
||||
(X16 $50 )
|
||||
dup >label RP 2+
|
||||
dup >label UP 2+
|
||||
|
||||
|
|
@ -1602,13 +1602,6 @@ Code clearstack
|
|||
: heap? ( addr -- flag)
|
||||
heap up@ uwithin ;
|
||||
|
||||
| : heapmove ( from -- from)
|
||||
dup here over -
|
||||
dup hallot heap swap cmove
|
||||
heap over - last +! reveal ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 74, Hexblock 4a
|
||||
4a fthpage
|
||||
|
|
@ -1642,7 +1635,7 @@ Label docreate
|
|||
\ *** Block No. 75, Hexblock 4b
|
||||
4b fthpage
|
||||
|
||||
( 6502-align ?head | 08sep84bp)
|
||||
( 6502-align 08sep84bp)
|
||||
|
||||
| : 6502-align/1 ( adr -- adr' )
|
||||
dup $FF and $FF = - ;
|
||||
|
|
@ -1654,49 +1647,48 @@ Label docreate
|
|||
1 last +! 1 allot THEN ;
|
||||
|
||||
|
||||
Variable ?head 0 ?head !
|
||||
|
||||
: | ?head @ ?exit -1 ?head ! ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 76, Hexblock 4c
|
||||
4c fthpage
|
||||
|
||||
( warning Create 30dec84bp)
|
||||
\ warning ?heapmovetx | |on |off Create
|
||||
|
||||
Variable warning 0 warning !
|
||||
|
||||
| : exists?
|
||||
| : exists? ( -- )
|
||||
warning @ ?exit
|
||||
last @ current @ (find nip
|
||||
IF space last @ .name ." exists " ?cr
|
||||
THEN ;
|
||||
|
||||
Variable ?heapmovetx 0 ?heapmovetx !
|
||||
|
||||
| : heapmove ( from size -- offset )
|
||||
over >r dup hallot ( from size ) heap swap cmove ( )
|
||||
heap r> - ;
|
||||
|
||||
| : heapmove1x ( from size -- offset )
|
||||
heapmove ?heapmovetx off ;
|
||||
|
||||
: | ['] heapmove1x ?heapmovetx ! ;
|
||||
: |on ['] heapmove ?heapmovetx ! ;
|
||||
: |off ?heapmovetx off ;
|
||||
|
||||
: Create
|
||||
here blk @ , current @ @ ,
|
||||
name c@ dup 1 $20
|
||||
uwithin not Abort" invalid name"
|
||||
here last ! 1+ allot
|
||||
exists? ?head @
|
||||
IF 1 ?head +! dup 6502-align/1 ,
|
||||
\ Pointer to code
|
||||
heapmove $20 flag! 6502-align/1 dp !
|
||||
here
|
||||
blk @ , current @ @ ,
|
||||
name c@
|
||||
dup 1 $20 uwithin not Abort" invalid name"
|
||||
here last ! 1+ allot exists?
|
||||
?heapmovetx @
|
||||
IF dup 6502-align/1 , \ Pointer to code
|
||||
dup here over -
|
||||
?heapmovetx perform last +!
|
||||
$20 flag! 6502-align/1 dp !
|
||||
ELSE 6502-align/2 drop
|
||||
THEN reveal 0 ,
|
||||
;Code docreate jmp end-code
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 77, Hexblock 4d
|
||||
4d fthpage
|
||||
|
||||
|
|
@ -1797,8 +1789,8 @@ Variable warning 0 warning !
|
|||
: User Create 2 uallot c,
|
||||
;Code SP 2dec 2 # ldy
|
||||
W )Y lda clc UP adc SP X) sta
|
||||
txa iny UP 1+ adc 1 # ldy
|
||||
SP )Y sta Next jmp end-code
|
||||
dey txa UP 1+ adc SP )Y sta
|
||||
Next jmp end-code
|
||||
|
||||
: Alias ( cfa --)
|
||||
Create last @ dup c@ $20 and
|
||||
|
|
@ -1818,6 +1810,13 @@ Variable warning 0 warning !
|
|||
|
||||
( voc-link vp current context also bp)
|
||||
|
||||
\ vp contains the vocabulary search oder respectively stack.
|
||||
\ vp/vp+1: order/stack size. 0 = one vocabulary on the stack
|
||||
\ vp+2/vp+3: bottom vocabulary on the stack
|
||||
\ ...
|
||||
\ vp+N+2/vp+N+3: the current context vocabulary, the top of stack,
|
||||
\ if N is the content of vp/vp+1.
|
||||
\ The top two vocabularies are the same after also is called.
|
||||
Create vp $10 allot
|
||||
Variable current
|
||||
|
||||
|
|
@ -1961,6 +1960,8 @@ Label findloop 0 # ldy
|
|||
( find ' ['] 13jan85bp)
|
||||
|
||||
: find ( string -- cfa n / string false)
|
||||
\ Skip the top vocabulary in the search order if it's equal to the
|
||||
\ second in the search order, as is the case after also is called.
|
||||
context dup @ over 2- @ = IF 2- THEN
|
||||
BEGIN under @ (find
|
||||
IF nip found exit THEN
|
||||
|
|
@ -2404,21 +2405,30 @@ Defer init-buffers ' noop IS init-buffers
|
|||
name> under 1+ u< swap heap? or ;
|
||||
|
||||
| : endpoints ( addr -- addr symb)
|
||||
heap voc-link >r
|
||||
BEGIN r> @ ?dup \ through all Vocabs
|
||||
WHILE dup >r 4 - >r \ link on returnst.
|
||||
BEGIN r> @ >r over 1- dup r@ u<
|
||||
\ until link or
|
||||
swap r@ 2+ name> u< and
|
||||
\ code under adr
|
||||
WHILE r@ heap? [ 2dup ] UNTIL
|
||||
\ heap is the starting value for symb
|
||||
\ at the end symb is heap or 2 + the highest of all cfas that are
|
||||
\ either in the heap or u> addr
|
||||
heap voc-link >r ( addr symb / R: voc-link )
|
||||
BEGIN \ outer loop through all vocabs
|
||||
r> @ ?dup ( addr symb / R: ) \ this is the word's exit point
|
||||
WHILE dup >r 4 - >r ( addr symb / R: next-voc prev-lfa )
|
||||
BEGIN \ inner loop through all words of a vocab
|
||||
r> @ >r ( R: prev-voc next-lfa )
|
||||
over 1- dup r@ u<
|
||||
( addr heap addr-1 flag:addr-1_u<_next-lfa_? )
|
||||
swap r@ 2+ name> u<
|
||||
( addr heap flag:addr-1_u<_next-lfa_? flag:addr-1_u<_next-cfa_? )
|
||||
and ( addr heap flag )
|
||||
\ flag means both lfa and cfa of next word are still u> addr-1
|
||||
\ i.e. WHILE flag means exit loop if either lfa or cfa u<= addr
|
||||
WHILE r@ heap? [ 2dup ] UNTIL \ Continue loop if lfa not on heap
|
||||
\ search for a name in heap
|
||||
r@ 2+ |? IF over r@ 2+ forget?
|
||||
IF r@ 2+ (name> 2+ umax
|
||||
THEN \ then update symb
|
||||
THEN
|
||||
REPEAT rdrop
|
||||
REPEAT ;
|
||||
REPEAT rdrop ( R: next-voc )
|
||||
REPEAT ;
|
||||
|
||||
|
||||
\ *** Block No. 114, Hexblock 72
|
||||
|
|
@ -2426,23 +2436,41 @@ Defer init-buffers ' noop IS init-buffers
|
|||
|
||||
\ remove 23jul85we
|
||||
|
||||
| Code remove ( dic symb thr - dic symb)
|
||||
| Code remove ( dict symb thread - dict symb)
|
||||
\ thread: vocabulary linked list
|
||||
\
|
||||
5 # ldy [[ SP )Y lda N ,Y sta dey 0< ?]
|
||||
\ N+4/5: dict N+2/3: symb N+0/1: thread
|
||||
user' s0 # ldy
|
||||
clc UP )Y lda 6 # adc N 6 + sta
|
||||
iny UP )Y lda 0 # adc N 7 + sta
|
||||
1 # ldy
|
||||
\ N+6/7: s0
|
||||
[[ N X) lda N 8 + sta
|
||||
N )Y lda N 9 + sta N 8 + ora 0<>
|
||||
\ N+8/9: next ptr in thread
|
||||
\ compare N+8/9 next ptr to s0 in N+6/7:
|
||||
?[[ N 8 + lda N 6 + cmp
|
||||
N 9 + lda N 7 + sbc CS
|
||||
\ CS aka u>= :
|
||||
\ compare N+8/9 next ptr to symb N+2/3
|
||||
?[ N 8 + lda N 2 + cmp
|
||||
N 9 + lda N 3 + sbc
|
||||
\ CC aka u< :
|
||||
\ compare N+4/5 dict to next ptr N+8/9
|
||||
][ N 4 + lda N 8 + cmp
|
||||
N 5 + lda N 9 + sbc
|
||||
]? CC
|
||||
\ CC aka u< i.e.
|
||||
\ either (inner CS above) s0 u<= next ptr u< symb
|
||||
\ or (inner CC above) dict u< next ptr u< s0
|
||||
\ let current ptr's adr point to next ptr's adr,
|
||||
\ i.e. remover next ptr from vocabulary thread.
|
||||
?[ N 8 + X) lda N X) sta
|
||||
N 8 + )Y lda N )Y sta
|
||||
\ CS aka u>= :
|
||||
\ let next ptr N+8/9 be current ptr N+0/1
|
||||
\ i.e. leave next ptr in vocabulary thread.
|
||||
][ N 8 + lda N sta
|
||||
N 9 + lda N 1+ sta ]?
|
||||
]]? (drop jmp end-code
|
||||
|
|
@ -2455,17 +2483,17 @@ Defer init-buffers ' noop IS init-buffers
|
|||
|
||||
( remove- forget-words 29apr85bp)
|
||||
|
||||
| : remove-words ( dic symb -- dic symb)
|
||||
| : remove-words ( dict symb -- dict symb)
|
||||
voc-link BEGIN @ ?dup
|
||||
WHILE dup >r 4 - remove r> REPEAT ;
|
||||
|
||||
| : remove-tasks ( dic --)
|
||||
| : remove-tasks ( dict --)
|
||||
up@ BEGIN 1+ dup @ up@ -
|
||||
WHILE 2dup @ swap here uwithin
|
||||
IF dup @ 1+ @ over ! 1- ELSE @ THEN
|
||||
REPEAT 2drop ;
|
||||
|
||||
| : remove-vocs ( dic symb -- dic symb)
|
||||
| : remove-vocs ( dict symb -- dict symb)
|
||||
voc-link remove thru.vocstack
|
||||
DO 2dup I @ -rot uwithin
|
||||
IF [ ' Forth 2+ ] Literal I ! THEN
|
||||
|
|
@ -2484,7 +2512,13 @@ Defer custom-remove
|
|||
|
||||
( deleting words from dict. 13jan83ks)
|
||||
|
||||
| : forget-words ( dic symb --)
|
||||
\ forget-words use cases:
|
||||
\ clear: dict=here, symb=up@
|
||||
\ forget: dict=cfa-to-forget,
|
||||
\ symb=umax(heap, 2 + (highest cfa either in heap or u> dict)
|
||||
\ empty: dict=here@cold, symb=up@
|
||||
\ save: dict=here, symb=up@
|
||||
| : forget-words ( dict symb --)
|
||||
over remove-tasks remove-vocs
|
||||
remove-words custom-remove
|
||||
heap swap - hallot dp ! 0 last ! ;
|
||||
|
|
|
|||
|
|
@ -11,17 +11,21 @@ Target
|
|||
|
||||
Forth also definitions
|
||||
|
||||
(C16 : (16 ) (C64 : (64 ) (X16 : (CX ) ; immediate
|
||||
|
||||
(C16 : (64 ) \ jumps belhind C)
|
||||
(C64 : (16 )
|
||||
(X16 : (CX )
|
||||
(X16 : (64 )
|
||||
BEGIN name count dup 0=
|
||||
abort" C) missing" 2 = >r
|
||||
@ [ Ascii C Ascii ) $100 * + ] Literal
|
||||
= r> and UNTIL ; immediate
|
||||
|
||||
: C) ; immediate
|
||||
(C16 ' (64 alias (CX immediate )
|
||||
(C64 ' (16 alias (CX immediate )
|
||||
(X16 ' (64 alias (16 immediate )
|
||||
|
||||
(C16 : (16 ) (C64 : (64 ) (X16 : (CX ) ; immediate
|
||||
: C) ; immediate
|
||||
|
||||
: forth-83 ; \ last word in Dictionary
|
||||
|
||||
|
|
|
|||
|
|
@ -28,5 +28,5 @@ here dup origin!
|
|||
$100 allot
|
||||
|
||||
Create logo
|
||||
(C16+ ," volksFORTH-83 3.91-C16+ " )
|
||||
(C16- ," volksFORTH-83 3.91-C16- " )
|
||||
(C16+ ," volksFORTH-83 3.9.2-C16+ " )
|
||||
(C16- ," volksFORTH-83 3.9.2-C16- " )
|
||||
|
|
|
|||
|
|
@ -28,4 +28,4 @@ here dup origin!
|
|||
$100 allot
|
||||
|
||||
Create logo
|
||||
," volksFORTH-83 3.91-C64 "
|
||||
," volksFORTH-83 3.9.2-C64 "
|
||||
|
|
|
|||
|
|
@ -27,4 +27,4 @@ here dup origin!
|
|||
$100 allot
|
||||
|
||||
Create logo
|
||||
," volksFORTH-83 3.91-X16 "
|
||||
," volksFORTH-83 3.9.2-X16 "
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ $FFA5 >label ACPTR
|
|||
$FFC6 >label CHKIN
|
||||
$FFC9 >label CHKOUT
|
||||
$FFD2 >label CHROUT
|
||||
$FFCF >label CHRIN
|
||||
$FF81 >label CINT
|
||||
$FFA8 >label CIOUT
|
||||
$FFC3 >label CLOSE
|
||||
|
|
@ -25,5 +26,6 @@ $FF96 >label TKSA
|
|||
$FFEA >label UDTIM
|
||||
$FFAE >label UNLSN
|
||||
$FFAB >label UNTLK
|
||||
$FFCF >label CHRIN
|
||||
$FF99 >label MEMTOP
|
||||
$FFBD >label SETNAM
|
||||
$FFBA >label SETLFS
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ include vf-lbls-cbm.fth
|
|||
\ C16-Labels clv13.4.87)
|
||||
|
||||
0ff4c >label ConOut
|
||||
090 >label IOStatus
|
||||
09a >label MsgFlg
|
||||
099 >label OutDev
|
||||
098 >label InDev
|
||||
|
|
@ -55,8 +56,6 @@ end-code
|
|||
|
||||
include vf-sys-cbm.fth
|
||||
|
||||
: i/o-status? $90 c@ ;
|
||||
|
||||
|
||||
\ *** Block No. 143, Hexblock 8f
|
||||
\ ... continued
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ include vf-lbls-cbm.fth
|
|||
\ C64-Labels clv13.4.87)
|
||||
|
||||
0E716 >label ConOut
|
||||
090 >label IOStatus
|
||||
09d >label MsgFlg
|
||||
09a >label OutDev
|
||||
099 >label InDev
|
||||
|
|
@ -58,8 +59,6 @@ Code curoff ( --)
|
|||
|
||||
include vf-sys-cbm.fth
|
||||
|
||||
: i/o-status? $90 c@ ;
|
||||
|
||||
|
||||
\ *** Block No. 143, Hexblock 8f
|
||||
\ ... continued
|
||||
|
|
|
|||
|
|
@ -99,6 +99,9 @@ Output: display [ here output ! ]
|
|||
\ *** Block No. 135, Hexblock 87
|
||||
87 fthpage
|
||||
|
||||
Code i/o-status? ( -- n )
|
||||
IOStatus lda Push0A jmp end-code
|
||||
|
||||
\ b/blk drive >drive drvinit clv14:2x87
|
||||
|
||||
400 Constant b/blk
|
||||
|
|
@ -143,10 +146,10 @@ Label nodevice 0 # ldx 1 # ldy
|
|||
\ ?device clv12jul87
|
||||
|
||||
Label (?dev
|
||||
90 stx (C16 $ae sta ( ) LISTEN jsr
|
||||
IOStatus stx (C16 $ae sta ( ) LISTEN jsr
|
||||
\ because of error in OS
|
||||
60 # lda SECOND jsr UNLSN jsr
|
||||
90 lda 0<> ?[ pla pla nodevice jmp ]?
|
||||
IOStatus lda 0<> ?[ pla pla nodevice jmp ]?
|
||||
rts end-code
|
||||
|
||||
Code (?device ( dev --)
|
||||
|
|
@ -212,7 +215,8 @@ Code bus@ ( -- 8b)
|
|||
bounds ?DO bus@ I c! LOOP pause ;
|
||||
|
||||
: derror? ( -- flag )
|
||||
disk $F busin bus@ dup Ascii 0 -
|
||||
IF BEGIN emit bus@ dup #cr = UNTIL
|
||||
0= cr ELSE BEGIN bus@ #cr = UNTIL
|
||||
THEN 0= busoff ;
|
||||
disk $F busin bus@ dup Ascii 0 =
|
||||
IF drop BEGIN bus@ drop i/o-status? UNTIL false
|
||||
ELSE BEGIN emit bus@ i/o-status? UNTIL emit true THEN
|
||||
busoff ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ include vf-lbls-cbm.fth
|
|||
\ X16 labels
|
||||
|
||||
0c28c >label ConOut
|
||||
0286 >label IOStatus
|
||||
028c >label MsgFlg
|
||||
028b >label OutDev
|
||||
028a >label InDev
|
||||
|
|
@ -29,18 +30,23 @@ include vf-lbls-cbm.fth
|
|||
\ X16 c64key? getkey
|
||||
|
||||
Code c64key? ( -- flag)
|
||||
9f61 ldx
|
||||
0 # lda 9f61 sta
|
||||
0a00a lda
|
||||
0<> ?[ 0FF # lda ]? pha
|
||||
9f61 stx
|
||||
Push jmp end-code
|
||||
|
||||
Code getkey ( -- 8b)
|
||||
9f61 lda N sta
|
||||
0 # lda 9f61 sta
|
||||
0a00a lda 0<>
|
||||
?[ sei 0a000 ldy
|
||||
[[ 0a000 1+ ,X lda 0a000 ,X sta inx
|
||||
0a00a cpx 0= ?]
|
||||
0a00a dec tya cli 0A0 # cmp
|
||||
0a00a dec
|
||||
N lda 9f61 sta
|
||||
tya cli 0A0 # cmp
|
||||
0= ?[ bl # lda ]?
|
||||
]?
|
||||
Push0A jmp end-code
|
||||
|
|
@ -70,8 +76,6 @@ Code curoff ( --)
|
|||
|
||||
include vf-sys-cbm.fth
|
||||
|
||||
: i/o-status? $0286 c@ ;
|
||||
|
||||
|
||||
\ *** Block No. 143, Hexblock 8f
|
||||
\ ... continued
|
||||
|
|
|
|||
62
6502/C64/src/x16tmpheap.fth
Normal file
62
6502/C64/src/x16tmpheap.fth
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
|
||||
\ This is a custom implementation of tmpheap for the X16 which
|
||||
\ allocates the tmpheap in a RAM bank and moves definitons prefixed
|
||||
\ with || or within a ||on to ||off range there.
|
||||
\ tmpclear will remove all words on the tmpheap, wheras regular clear
|
||||
\ will remove all words on tmpheap and heap together.
|
||||
|
||||
\ Other than the reference tmpheap living on the regular heap, this
|
||||
\ custom tmpheap needs no initialization as its position and
|
||||
\ size (8k) is fixed.
|
||||
|
||||
User tmpheap[
|
||||
User tmpheap>
|
||||
User ]tmpheap
|
||||
|
||||
\ $9f61 is the X16 RAM bank select register. This will change to $0001
|
||||
\ in the next X16 board version.
|
||||
\ 1 is the RAM bank selected for the tmpheap. RAM bank 0 is used by the
|
||||
\ X16 KERNAL. The banked RAM lives from $a000 to $bfff.
|
||||
1 $9f61 c! $a000 tmpheap[ ! $c000 dup ]tmpheap ! tmpheap> !
|
||||
|
||||
: mk-tmp-heap ( size -- )
|
||||
heap dup ]tmpheap ! tmpheap> ! hallot heap tmpheap[ ! ;
|
||||
|
||||
: tmp-hallot ( size -- addr )
|
||||
tmpheap> @ swap -
|
||||
dup tmpheap[ @ u< abort" tmp heap overflow"
|
||||
dup tmpheap> ! ;
|
||||
|
||||
| : tmp-heapmove ( from from size -- from offset )
|
||||
dup tmp-hallot swap cmove
|
||||
tmpheap> @ over - ;
|
||||
|
||||
| : tmp-heapmove1x ( from size -- from offset )
|
||||
tmp-heapmove ?heapmovetx off ;
|
||||
|
||||
: || ['] tmp-heapmove1x ?heapmovetx ! ;
|
||||
: ||on ['] tmp-heapmove ?heapmovetx ! ;
|
||||
: ||off ?heapmovetx off ;
|
||||
|
||||
|
||||
| : remove-tmp-words-in-voc ( voc -- )
|
||||
BEGIN dup @ ?dup WHILE ( thread next-in-thread )
|
||||
dup tmpheap[ @ ]tmpheap @ uwithin IF ( thread next-in-thread )
|
||||
@ ?dup IF ( thread next-next-in-thread ) over !
|
||||
ELSE ( thread ) off exit THEN
|
||||
ELSE ( thread next-in-thread ) nip
|
||||
THEN
|
||||
REPEAT drop ;
|
||||
|
||||
| : remove-tmp-words ( -- )
|
||||
voc-link BEGIN @ ?dup
|
||||
WHILE dup 4 - remove-tmp-words-in-voc REPEAT ;
|
||||
|
||||
: tmpclear ( -- )
|
||||
remove-tmp-words
|
||||
\ Uncomment the following line to help determine the ideal tmpheap
|
||||
\ size for your project.
|
||||
\ tmpheap> @ tmpheap[ @ - cr u. ." tmpheap spare"
|
||||
]tmpheap @ tmpheap> ! last off ;
|
||||
|
||||
' tmpclear is custom-remove
|
||||
Loading…
Reference in New Issue
Block a user