mirror of
https://github.com/forth-ev/VolksForth.git
synced 2025-02-21 08:28:59 +00:00
486 lines
170 KiB
Plaintext
486 lines
170 KiB
Plaintext
clv06jan88 \ Directory of uf-Ed-clv06jan clv02feb88 3 files 4 .page in Forth 5 >scr CBM-Screencode-Conversion 6 scrAdr curAdr cols rows 7- 9 screen Output-Vektor 10-13 .page in Assembler 16-19 .page 2.versuch 20 Edi-Test 40 " 60 " 85ff shadows \ test clv12jan88 $100 $100 Task testtask multitask : tt testtask activate BEGIN $80 $c00 ctoggle pause REPEAT ; \ revers on/off at top left corner \ files clv20jan88 | : skp bus@ drop bus@ drop ; | : wrd bus@ bus@ $100 * + . ; | : str BEGIN bus@ ?dup WHILE emit REPEAT ; : files \ Filename kann folgen (drv @ 8 + dup 0 busopen " $0:" count bustype bl parse bustype " *" count bustype busoff derror? ?exit dup 0 busin skp skp \ Sector,Zeilenlink BEGIN cr wrd str skp $90 c@ UNTIL 0 busclose derror? ?exit ; \ .line .page in Forth clv11jan88 : >count ( ad l ad+ l- --ad+ l- ad cnt) 2swap 2 pick - ; : .line ( adr len col--adr+ len- col) >r 2dup #cr scan >count r@ - swap r@ + swap 0 max cols umin type dup IF 1- swap 1+ swap THEN r> ; : xpage 0 0 at $0c00 $400 $2e fill ; : .page1 ( adr len col-- adr+ len- col) xpage rows 1 DO .line cr LOOP .line ; \ >scr clv19jan88 : Char: Create ;code ( char--char') sp x) lda tax .a lsr .a lsr .a lsr .a lsr .a lsr .a asl tay iny iny txa iny W )y and dey W )y ora 0 # ldx sp x) sta 1 # ldy next jmp end-code Char: >scr ( +--or---+ +---and--+ ) ( $0-1f) Ascii . c, 0 c, ( 20-3f) %00000000 c, %11111111 c, ( 40-5f) %00000000 c, %00011111 c, ( 60-7f) %00000000 c, %01011111 c, ( 80-9f) Ascii . c, 0 c, ( a0-bf) Ascii . c, 0 c, ( c0-df) %00000000 c, %01011111 c, ( e0-ff) Ascii . c, 0 c, \needs scrAdr --> \\ : C> Create does> ( char--char') >r dup 2/ 2/ 2/ 2/ 2/ 2* r> + dup c@ -rot 1+ c@ and or ; \ scrAdr curAdr cols rows clv11jan88 $0c00 Constant scrAdr Variable curAdr scrAdr curAdr ! &40 Constant cols &25 Constant rows \ screen Output-Vektor clv11jan88 \needs >scr 5 load \ CBM-Screencodes \ & scrAdr .. 1 2 +thru \\ curon/off muss gepatched werden, da dummerweise nicht vektorisiert ' c64key >body Constant >curon ' c64key >body $a + Constant >curoff : scrOn screen keyboard ['] scrcur dup >curon ! >curoff ! save ; : scrOff display [ editor ] ediboard ['] curon >curon ! ['] curoff >curoff ! save ; \ ..screen.. clv11jan88 : scrpage scrAdr [ cols rows * ] Literal bl fill scrAdr curAdr ! ; : scroll scrAdr dup cols + swap [ cols rows 1- * ] Literal cmove [ scrAdr cols rows 1- * + ] Literal cols bl fill cols negate curAdr +! ; : ?scroll [ scrAdr cols rows * + ] Literal curAdr @ - ?exit scroll ; : scrcur ?scroll $80 curAdr @ ctoggle ; \ ..screen clv11jan88 : scrat? ( --row col) curAdr @ scrAdr - cols u/mod swap ; : scrat ( row col--) swap cols * + scrAdr + curAdr ! ?scroll ; : scrcr scrat? drop 1+ 0 scrat ; : scremit ( char--) >scr \ cbmScreenCode ?scroll curAdr @ c! 1 curAdr +! ; : scrtype ( adr +n--) bounds ?DO I c@ scremit LOOP ; : scrdel -1 curAdr +! bl scremit -1 curAdr +! ; Output: screen scremit scrcr scrtype scrdel scrpage scrat scrat? ; \ .page clv14jan88 Onlyforth \needs >scr 5 load \ CBM-Screencodes ' >scr >body >Label scrtab Label (>scr ( AR=char;char') \ XR<> \ converts char to CBM-Screencode pha .a lsr .a lsr .a lsr .a lsr .a lsr .a asl tax pla inx scrtab ,x and dex scrtab ,x ora rts end-code \ N:curCol +2:len +4:adr +6:actLn \ +8:tmpCol +a:exitSp YR=col --> \ (emit 3.vers clv14jan88 Label neg ( XR=adr;) \ 2erKompl von adr sec 0 # lda 0 ,x sbc 0 ,x sta 0 # lda 1 ,x sbc 1 ,x sta rts Label pClr ( N+6:curLn,YR=col) \ clears end of Line, exit on screenEnd bl # lda [[ cols # cpy 0<> ?[[ N 6 + )y sta iny ]]? clc cols # lda N 6 + adc N 6 + sta CS ?[ N 7 + inc ]? 0 # ldy scrAdr cols rows * + $100 u/mod N 6 + dup 1+ lda swap # cmp CC ?[ rts ]? lda # cmp CC ?[ rts ]? N $a + ldx txs \ Screen:End reached N 2+ # ldx neg jsr 0 # ldx 3 # lda \ setback to stack .A asl tay [[ SP dec dey 0= ?] tay dey [[ N ,y lda SP )y sta dey 0= ?] iny next jmp end-code --> \ pPut pGet pCol clv11jan88 Label pPut ( AR=char;) \ puts char on screen. Noop if beyond cols # cpy CC ?[ (>scr jsr 0 # ldx N 6 + )y sta iny ]? rts end-code Label pGet ( ;AR:char,Z:char==#cr) \ char from RAM. Ends Page if exhausted N 4 + winc N 2+ winc 0<> ?[ N 4 + x) lda #cr # cmp rts ]? [[ pClr jsr ]] end-code \ stream:end Label pCol \ skips cols left of screen N 8 + N 2dup lda sta 1+ lda 1+ sta N 8 + dup winc # ldx neg jsr 0 # ldx [[ N 8 + winc 0= ?[ rts ]? pGet jsr 0= ?[ pClr jsr pCol jmp ]? ]] end-code --> \ .page clv14jan88 Code .page ( adr len col--ad+ len- col) \ displays text at adr/len \ interprets #cr,skips col (left of scr) \ setup of N... y 3 # lda setup jsr N 2+ # ldx neg jsr \ setup of actLn N 6 + ' scrAdr >body 2dup lda sta 1+ lda 1+ sta tsx N $a + stx \ Exit SP 0 # ldx 0 # ldy N 4 + wdec N 2+ wdec \ MainLoop [[ pCol jsr [[ pGet jsr 0<> ?[[ pPut jsr ]]? pClr jsr ]] end-code \ .page 2.Versuch mit fOut/In clv25jan88 Onlyforth \needs >scr 5 load \ CBM-Screencodes ' >scr >body >Label scrtab Label (>scr ( AR=char;char') \ XR<> \ converts char to CBM-Screencode pha .a lsr .a lsr .a lsr .a lsr .a lsr .a asl tax pla inx scrtab ,x and dex scrtab ,x ora rts end-code \ N:scrCol +2:adr +4:none +6:actLn \ +8:tmpCol +a:exitSp YR=col --> \ (emit 3.vers clv25jan88 Label neg ( XR=adr;) \ 2erKompl von adr sec 0 # lda 0 ,x sbc 0 ,x sta 0 # lda 1 ,x sbc 1 ,x sta rts Label pClr ( N+6:curLn,YR=col) \ clears end of Line, exit on screenEnd bl # lda [[ cols # cpy 0<> ?[[ N 6 + )y sta iny ]]? clc cols # lda N 6 + adc N 6 + sta CS ?[ N 7 + inc ]? 0 # ldy scrAdr cols rows * + $100 u/mod N 6 + dup 1+ lda swap # cmp CC ?[ rts ]? lda # cmp CC ?[ rts ]? N $a + ldx txs \ Screen:End reached SP 2dec 0 # ldx 1 # ldy N 2+ lda SP x) sta N 3+ lda SP )y sta next jmp end-code --> \ pPut pGet pCol clv25jan88 Label pPut ( AR=char;) \ puts char on screen. Noop if beyond cols # cpy CC ?[ (>scr jsr 0 # ldx N 6 + )y sta iny ]? rts end-code Label pGet ( ;AR:char,Z:char==#cr) \ char from RAM. Ends Page if exhausted N 2+ winc N 2+ lda fOut cmp 0= \ fOut reached? ?[ N 3 + lda fOut 1+ cmp 0= ?[ N 2+ fIn 2dup \ ..use fIn lda sta 1+ lda 1+ sta ]? ]? N 2+ lda fEnd cmp 0= \ fEnd reached? ?[ N 3 + lda fEnd 1+ cmp 0= ?[ [[ pClr jsr ]] ]? ]? \ ..clrPg N 2 + x) lda #cr # cmp rts end-code --> \ .page clv29jan88 Label pCol \ skips cols left of screen N 8 + N 2dup lda sta 1+ lda 1+ sta N 8 + dup winc # ldx neg jsr 0 # ldx [[ N 8 + winc 0= ?[ rts ]? pGet jsr 0= ?[ pClr jsr pCol jmp ]? ]] end-code Code .page2 ( adr col--ad+) \ uses fOut,fIn,fEnd \ displays text at adr/len \ interprets #cr,skips col (left of scr) \ setup of N... 2 # lda setup jsr \ setup of actLn N 6 + ' scrAdr >body 2dup lda sta 1+ lda 1+ sta tsx N $a + stx \ Exit SP 0 # ldx 0 # ldy N 2 + wdec \ MainLoop [[ pCol jsr [[ pGet jsr 0<> ?[[ pPut jsr ]]? pClr jsr ]] end-code clv11jan88 clv11jan88 \ Edi-Test-3 clv22feb88 \ mit Transfers-Luecke, .page in Forth, \ ziemlich langsam : tt limit $e800 - IF $e800 ['] limit >body ! &20 buffers THEN ; tt forget tt Onlyforth : rl [ blk @ ] Literal l ; \needs memtop $fd00 Constant memtop 1 +load \ Variables \needs >scr 5 load 2 &19 +thru \ forget initFile 2 &19 +thru : .x over u. ." :" type ; : .. fBeg @ fOut @ over - .x fIn @ fEnd @ over - .x cr ; \ Variables clv25jan88 Variable lastKey Variable curPos Variable scrBeg Variable scrCol Variable exitRP Variable tab \ key-Tab Create fName $20 allot Variable fBeg Variable fEnd Variable fOut \ Beginn von room Variable fIn \ Ende von room \ edi-test info clv25jan88 : wait BEGIN key? UNTIL ; : sat cols 1- min swap rows 1- min swap at ; : .at 0 10 at 2dup swap . . ." AT" sat ; Defer 'at ' .at Is 'at : wderror? derror? dup IF wait THEN ; Defer 'derror? ' wderror? Is 'derror? : .v ( adr--) base push hex cr dup @ 5 u.r ." " 2- >name .name ." !" ; : .i cr .s curPos .v scrCol .v fbeg .v scrbeg .v fOut .v fIn .v fend .v cr fbeg @ 1- c@ . fend @ @ . cr ; \ fileOut/In clv25jan88 : fType ( from u --) fOut @ 2dup + ( fr u fOut@ fOut@+u ) dup fIn @ u> abort" no room" fOut ! ( fr u fOut@) swap cmove ; : fEmit ( char--) sp@ 1 fType drop ; : fCr #cr fEmit ; : fDel fOut @ 1- fBeg @ umax fOut ! ; : fPage fBeg @ fOut @ over - ( from count) over fIn @ fOut @ - + swap cmove> fBeg @ dup fOut ! fIn @ fOut @ - + fIn ! ; : fAt 2drop ; : fAt? 0.0 ; Output: fileOut fEmit fCr fType fDel fPage fAt fAt? ; : fKey? ( --flag) fIn @ fEnd @ u< ; : fKey ( -- 8b) fKey? IF fIn @ c@ 1 fIn +! exit THEN $1a ; Input: fileIn fKey fKey? c64decode c64expect ; \ tva cr? fe? clv30jan88 \needs Code .( ??! Code ??!) quit Assembler \needs wcmp .( ??! wcmp[debug] ??!) quit Code cr? ( adr--adr flag) SP x) lda N sta SP )y lda N 1+ sta N x) lda #cr # cmp 0<> ?[ Label (fe? N fEnd wcmp CC ?[ N fBeg wcmp CS ?[ 0 # lda pushA jmp ]? ]? ]? $ff # lda pushA jmp end-code Code fe? SP x) lda N sta SP )y lda N 1+ sta (fe? jmp Code c? ( adr--adr flag) SP x) lda N sta SP )y lda N 1+ sta N fIn wcmp CC ?[ N fOut wcmp CS ?[ 0 # lda pushA jmp ]? ]? $ff # lda pushA jmp end-code \ c? bl? ..< ..> clv30jan88 \ fuer Laufzeitmessung: : cr? cr? ; : fe? fe? ; : c? c? ; ( adr--adr flag) : bl? cr? over c@ bl = or ; \ space ( adr--adr) : c< 1- c? ?exit drop fOut @ 1- ; : c> 1+ c? ?exit drop fIn @ ; : bl> BEGIN c> bl? not UNTIL ; : cr> c> ; : w< BEGIN c< bl? UNTIL ; \ word : w> BEGIN c> bl? UNTIL ; : l< BEGIN c< cr? UNTIL ; \ line : l> BEGIN c> cr? UNTIL ; : p> rows 0 DO l> LOOP ; : p< rows 0 DO l< LOOP ; : l<? ( cur--cur col) dup dup l< 1+ - ; \\ : fe? dup fBeg @ fEnd @ uwithin not ; : cr? dup c@ #cr = swap fe? or ; : c? dup fOut @ fIn @ uwithin not ; \ initFile clv30jan88 : initFile $100 \ cursorRoom fBeg @ 2dup + over fEnd @ swap - cmove> fBeg @ dup fOut ! over + fIn ! fEnd +! $0d0d fEnd @ ! fOut @ curPos ! ; : moveroom ( curAdr --) dup curPos ! c? not IF drop exit THEN fOut @ u< IF curPos @ fIn @ fOut @ - curPos @ + fOut @ curPos @ - dup negate dup fOut +! fIn +! cmove> ELSE fIn @ fOut @ curPos @ fIn @ - dup dup fOut +! fIn +! fOut @ curPos ! cmove THEN ; \ baseMovements clv25jan88 : << ( --curAdr) curPos @ ; : >> ( curAdr--) fBeg @ umax fEnd @ umin moveroom ; \ : c+ ( col+ cur-) \ 1- l> >> << l< 1+ + ; : <<c ( --col lin) << dup l< under - swap ; : c>> ( col lin--) l> >> << l< + >> ; : c+ ( col lin col+--col lin) rot + swap ; : c= ( col lin col=--col lin) swap rot drop ; \ executables clv28jan88 ( --) : begLn << l< cr> >> ; : endLn << l> >> ; : up <<c l< c>> ; : down <<c l> c>> ; : lastPg <<c p< c>> ; : nextPg <<c p> c>> ; : begPg <<c drop scrBeg @ c>> ; : endPg <<c drop scrBeg @ p> l< c>> ; : beg <<c drop fBeg @ c< c>> ; : end <<c drop fEnd @ l< c>> ; : right <<c 1 c+ c>> ; : left <<c -1 c+ c>> ; : begScr <<c scrCol @ c= c>> ; : endScr <<c scrCol @ cols + 1- c= c>> ; \ ..exe clv28jan88 : doChar << dup fOut @ - 0 max 0 ?DO bl fEmit LOOP lastKey @ fEmit c> >> ; : backDel curPos @ fOut @ = IF fdel THEN left ; : delChar right backDel ; : exitEd exitRp @ rp! ; : info at? 5 0 at 2dup swap cr . . ." at" .i wait at ; : help tab @ BEGIN count WHILE dup @ >name .name 2+ REPEAT drop wait ; \ leer clv28jan88 \ writeFile readFile clv25jan88 Onlyforth : writeFile 0 (drv ! 8 2 busopen fName count bustype " ,p,w" count bustype busoff 'derror? ?exit 8 2 busout 0 0 bus! bus! fEnd @ fBeg @ BEGIN 2dup - WHILE dup c@ bus! c> REPEAT busoff 8 2 busclose 'derror? ?exit ; : readFile 0 (drv ! 8 2 busopen fName count bustype " ,p,r" count bustype busoff 'derror? ?exit fBeg @ 8 2 busin bus@ drop bus@ drop BEGIN bus@ over c! 1+ $90 c@ UNTIL fEnd ! busoff 8 2 busclose 'derror? ?exit initFile ; \ files clv25jan88 | : skp bus@ drop bus@ drop ; | : wrd bus@ bus@ $100 * + . ; | : str BEGIN bus@ ?dup WHILE emit REPEAT ; : files \ Filename kann folgen (drv @ 8 + dup 0 busopen " $0:" count bustype bl parse bustype " *" count bustype busoff derror? ?exit dup 0 busin skp skp \ Sector,Zeilenlink BEGIN cr wrd str skp $90 c@ UNTIL 0 busclose 'derror? ?exit wait ; \ loadFile clv28jan88 \\ noch alt : fLine #tib @ >tib @ + 1+ dup fEnd @ u> IF drop rdrop exit THEN dup 1- l> over - #tib ! >tib ! >in off ; : .fLine cr >tib @ dup 5 u.r space #tib @ type space ; : xx >tib push #tib push >in push r0 push ['] 'quit >body push ['] unnest Is 'quit ['] .status >body push rp@ r0 ! page ['] .fLine Is .status curPos @ >tib ! -1 #tib ! BEGIN fLine .status interpret REPEAT ; : loadFile curPos ! >r xx r> curPos @ wait ; \ fconvey clv28jan88 \ noch ungetestet : fConvey ( [from to]--) 1+ swap \ curPos @ -rot ?DO rows 0 DO #cr fEmit J block I c/l * + c/l fType LOOP 1 fDel LOOP ( drop ) ; \ .page 4.Ver Forth clv30jan88 : pPut ( char--) >scr curAdr @ c! 1 curAdr +! ; : pSpc ( u--) \ puts u spaces curAdr @ over bl fill curAdr +! ; : leap rdrop rdrop rdrop rdrop ; : .line ( col adr--col ad+) over 0 ?DO c> cr? IF cols pSpc leap THEN LOOP cols 0 DO c> cr? IF cols I - pSpc leap THEN dup c@ pPut LOOP l> ; : .page ( adr col--ad+) \ interprets cr,skips cols left of scr scrAdr curAdr ! swap rows 0 DO .line LOOP nip ; \ -&21 #entries +! forget pPut 0 4 +thru \ redraw show clv29jan88 : redraw curPos @ BEGIN scrBeg @ scrCol @ .page over u< WHILE dup p< scrBeg ! REPEAT drop ; : cursor curPos @ scrBeg @ -1 -rot BEGIN rot 1+ -rot l> 2dup u< UNTIL drop l<? scrCol @ - rot swap ( col+ @ + ) 'at drop ; : ?sR? curPos @ l<? ( col+ @ + ) dup cols - 1+ scrCol @ max min scrCol ! drop ; : ?sB? curPos @ scrBeg @ u> ?exit curPos @ l< scrBeg ! ; : show ?sB? ?sr? key? ?exit redraw key? ?exit cursor ; \ 0 3 +thru \ maintab clv25jan88 : A+ [compile] Ascii + ; : Ctr -$40 A+ ; : Cbm $60 A+ ; : Ct+ $40 A+ ; : => c, ' , ; Create maintab \ <key> c, ' word , Ctr ] => right Ct+ ] => left Ctr q => down Ct+ q => up Ctr u => begLn Ctr i => endLn Ctr h => begPg Ctr j => endPg Ctr g => lastPg Ctr k => nextPg Ctr b => beg Ctr n => end Ctr f => files \ Ctr l => loadFile Ctr c => exitEd Ctr t => backDel Ctr d => delChar Ctr w => writeFile Ctr r => readFile Ctr o => info Ctr p => help Ctr [ => redraw \ ESC 0 => doChar \ 0 2 +thru \ editop clv30jan88 : dokey lastKey @ tab @ 3 - BEGIN 3+ dup c@ WHILE 2dup c@ = UNTIL nip 1+ @ execute ; : editop rp@ exitRP ! \ fuer exitEd maintab tab ! BEGIN key? 0= IF show THEN key lastKey ! dokey REPEAT ; \ edi3 test clv22feb88 : init limit 1+ dup fBeg ! dup fEnd ! dup curPos ! drop $0d fBeg @ 1- c! 0 scrCol ! fBeg @ 1- scrBeg ! initFile ; : red editop page ." end of edit" ; : edit bl parse $20 umin fName place init ( readFile ) red ; \needs new \\ \ Edi-Test-1 clv22feb88 \ ohne read/write : tt limit $e000 - IF $e000 ['] limit >body ! 20 buffers THEN ; tt forget tt Onlyforth \needs memtop $fd00 Constant memtop \needs .page &10 load 1 +load \ Variables .. &12 +load \ Test 2 &10 +thru &11 +load \ Test \ Variables clv14jan88 Variable curPos Variable scrCol Variable scrBeg Variable scrEnd Variable fBeg Variable fEnd Variable xroom Variable xroomlen Variable tab Variable col+ \ room clv11jan88 : ?enough ( n--n) dup xroomlen @ > abort" no room" ; : ?range ( adr n -- adr n) over xroom @ u> abort" beyond room" ; \ kriegt spaeter die verschieberei : decroom ( n--n) dup fEnd +! dup xroom +! dup negate xroomlen +! ; : room ( adr n -- adr n) ?enough ?range 2dup over + ( ad n ad=fr ad'=to ) xroom @ 2 pick - move ( adr n) decroom ; \\ : room ( adr n -- adr) ?enough ?range 2dup + -rot >r ( ad'=to ad) xroom @ over - ( ad' ad=fr cnt) 2 pick swap move ( ad' ) r> decroom ; \ insert back clv14jan88 : fType ( adr from u -- adr') swap >r room 2dup r> -rot cmove + ; : fEmit ( adr char--adr') >r rp@ 1 fType rdrop ; : fDel ( adr u -- adr') 2dup - fBeg @ u< ( a u a'<beg? ) IF drop dup fBeg @ - 0 min THEN negate room + ; \ cursor-movement clv14jan88 ( adr--adr') \ setzt #cr vor und nach File voraus : ?b fBeg @ umax ; : ?e fEnd @ umin ; Code (cr> sp x) lda N sta sp )y lda N 1+ sta #cr # lda [[ N winc N x) cmp 0= ?] N lda sp x) sta N 1+ lda sp )y sta next jmp end-code Code (cr< sp x) lda N sta sp )y lda N 1+ sta [[ N wdec #cr # lda N x) cmp 0= ?] N lda sp x) sta N 1+ lda sp )y sta next jmp end-code : cr< ?b (cr< ; : cr> ?e (cr> ; : pg< rows 0 DO cr< LOOP ; : pg> 1- rows 1- 0 DO cr> LOOP ; \\ : cr< ?b BEGIN 1- cr? UNTIL ; : cr> ?e BEGIN 1+ cr? UNTIL ; \ move-Base clv14jan88 : leftchars ( adr--adr u) dup dup cr< 1+ - ; : rightchars ( adr--adr u) dup 1- cr> over - ; : savCol dup dup cr< - col+ +! ; : useCol dup cr> over - col+ @ over - dup 0< IF + 0 THEN col+ ! + ; : noCol col+ off ; : cr? ( adr--adr flag) dup c@ #cr = ; : ?eL ?e dup 1- cr> fEnd @ - ?exit cr< ; \\ \ 0 6 +thru \ executables clv14jan88 ( rp char adr--rp char adr') : begLn noCol cr< 1+ ; : endLn noCol 1- cr> ; : up savCol cr< cr< useCol ; : down savCol 1- cr> ?eL useCol ; : lastPg savCol pg< useCol ; : nextPg savCol pg> ?eL useCol ; : begPg savCol drop scrBeg @ 1- useCol ; : endPg begPg nextPg ; : beg savCol drop fBeg @ 1- useCol ; : end savCol drop fEnd @ cr< useCol ; : right cr? IF 1 col+ +! ELSE 1+ THEN ; : left col+ @ IF -1 col+ +! ELSE 1- ?b THEN ; \ ..exe clv14jan88 : doChar col+ @ 0 ?DO bl fEmit LOOP noCol over fEmit ; : backDel col+ @ IF left ELSE 1 fDel THEN ; : delChar right backDel ; : wait key drop ; : exitEd nip swap rp! ; : info at? 5 0 at 2dup swap cr . . ." at" .i wait at ; : help tab @ BEGIN count WHILE dup @ >name .name 2+ REPEAT drop wait ; \ redraw show clv14jan88 : redraw BEGIN scrBeg @ fEnd @ over - scrCol @ .page drop drop over u< WHILE dup pg< 1+ scrBeg ! REPEAT ; ( adr--adr') : cursor \ dup curPos ! \ test scrBeg @ 1- -1 -rot BEGIN rot 1+ -rot cr> 2dup u> not UNTIL drop leftchars scrCol @ - rot swap col+ @ + 'at ; : ?sR? leftchars col+ @ + dup cols - 1+ scrCol @ max min scrCol ! ; : ?sB? dup scrBeg @ u< not ?exit dup begLn scrBeg ! ; : show ?sB? ?sr? redraw cursor ; \\ : ?sE? scrBeg @ pg> over u> ?exit dup pg< 1+ scrBeg ! ; : show ?sB? ?sr? ?se? redraw cursor ; \ 0 3 +thru \ maintab clv14jan88 : A+ [compile] Ascii + ; : Ctr -$40 A+ ; : Cbm $60 A+ ; : Ct+ $40 A+ ; : => c, ' , ; Create maintab \ <key> c, ' word , Ctr ] => right Ct+ ] => left Ctr q => down Ct+ q => up Ctr u => begLn Ctr i => endLn \ Ctr y => lastLn Ctr o => nextLn Ctr h => begPg Ctr j => endPg Ctr g => lastPg Ctr k => nextPg Ctr b => beg Ctr n => end Ctr c => exitEd Ctr t => backDel \ del-Taste Ctr d => delChar Ctr e => info Ctr w => help Ctr r => redraw 0 => doChar \ 0 2 +thru \ editop clv14jan88 : dokey ( adr char --adr) tab @ 3 - BEGIN 3+ dup c@ WHILE 2dup c@ = UNTIL 1+ @ ( adr char cfa ) >r swap r> execute nip ; : editop ( adr--adr) rp@ swap \ fuer exitEd BEGIN key? 0= IF show THEN key maintab tab ! dokey REPEAT ; \ edi1 test clv14jan88 : init limit $e000 u> abort" limit!!" 0 dup scrCol ! col+ ! limit 1+ dup scrBeg ! dup scrEnd ! dup fBeg ! dup fEnd ! dup curPos ! $0d fBeg @ 1- c! $0d0d fEnd @ ! dup $2 + xroom ! memtop xroom @ - xroomlen ! drop ; : red curPos @ editop curPos ! page ." end of edit" ; : edit init red ; \ edi1test info clv14jan88 Defer 'at : sat cols 1- min swap rows 1- min swap at ; : .at 0 10 at 2dup swap . . ." AT" sat ; ' sat Is 'at : nc curoff begin stop? until ; : .v ( adr--) base push hex cr dup @ 5 u.r ." " 2- >name .name ." !" ; : .i cr .s scrCol .v fbeg .v scrbeg .v scrend .v fend .v xroom .v xroomlen .v col+ .v cr fbeg @ 1- c@ . fend @ @ . cr ; clv20jan88 clv20jan88 clv20jan88 clv20jan88 clv20jan88 clv20jan88 \ edi1test info clv20jan88 Defer 'at : sat cols 1- min swap rows 1- min swap at ; : .at 0 10 at 2dup swap . . ." AT" sat ; ' sat Is 'at : nc curoff begin stop? until ; : .v ( adr--) base push hex cr dup @ 5 u.r ." " 2- >name .name ." !" ; : .i cr .s curPos .v scrCol .v fbeg .v scrbeg .v fend .v xroom .v xroomlen .v col+ .v cr fbeg @ 1- c@ . fend @ @ . cr ; \ Edi-Test-3 clv22feb88 \ schnell, obwohl room am Ende : tt limit $e000 - IF $e000 ['] limit >body ! 20 buffers THEN ; tt forget tt Onlyforth \needs memtop $fd00 Constant memtop \needs .page &10 load 1 &19 +thru \ Variables clv20jan88 Variable curPos Variable scrCol Variable scrBeg \ Variable scrEnd Variable col+ Create fName $20 allot Variable fBeg Variable fEnd Variable fPos Variable exitRP Variable xroom Variable xroomlen Variable tab \ room clv11jan88 : ?enough ( n--n) dup xroomlen @ > abort" no room" ; : ?range ( adr n -- adr n) over xroom @ u> abort" beyond room" ; \ kriegt spaeter die verschieberei : decroom ( n--n) dup fEnd +! dup xroom +! dup negate xroomlen +! ; : room ( adr n -- adr n) ?enough ?range 2dup over + ( ad n ad=fr ad'=to ) xroom @ 2 pick - move ( adr n) decroom ; \\ : room ( adr n -- adr) ?enough ?range 2dup + -rot >r ( ad'=to ad) xroom @ over - ( ad' ad=fr cnt) 2 pick swap move ( ad' ) r> decroom ; \ fType/Emit/Del clv20jan88 : initRoom fEnd @ $0d0d over ! $2 + xroom ! memtop xroom @ - xroomlen ! ; : fType ( adr from u -- adr') swap >r room 2dup r> -rot cmove + ; : fEmit ( adr char--adr') >r rp@ 1 fType rdrop ; : fDel ( adr u -- adr') 2dup - fBeg @ u< ( a u a'<beg? ) IF drop dup fBeg @ - 0 min THEN negate room + ; \ fKey/fExpect/fDecod clv20jan88 \\ noch unfertig: : fPtr? ( --adr) fPos @ ; : fKey? ( --flag) fPtr? fEnd @ u< ; : fKey ( -- 8b) fKey? IF fPtr? c@ ELSE oldIn THEN ; : c64decode ( addr cnt1 key -- addr cnt2) #bs case? IF dup IF del 1- THEN exit THEN #cr case? IF dup span ! exit THEN >r 2dup + r@ swap c! r> emit 1+ ; : c64expect ( addr len1 -- ) span ! 0 BEGIN dup span @ u< WHILE key decode REPEAT 2drop space ; Input: fIn c64key true c64decode c64expect ; \ edi1test info clv20jan88 Defer 'at : sat cols 1- min swap rows 1- min swap at ; : .at 0 10 at 2dup swap . . ." AT" sat ; ' sat Is 'at : nc curoff begin stop? until ; : .v ( adr--) base push hex cr dup @ 5 u.r ." " 2- >name .name ." !" ; : .i cr .s curPos .v scrCol .v fbeg .v scrbeg .v fend .v xroom .v xroomlen .v col+ .v cr fbeg @ 1- c@ . fend @ @ . cr ; \ cursor-movement clv14jan88 ( adr--adr') \ setzt #cr vor und nach File voraus : ?b fBeg @ umax ; : ?e fEnd @ umin ; Code (cr> sp x) lda N sta sp )y lda N 1+ sta #cr # lda [[ N winc N x) cmp 0= ?] N lda sp x) sta N 1+ lda sp )y sta next jmp end-code Code (cr< sp x) lda N sta sp )y lda N 1+ sta [[ N wdec #cr # lda N x) cmp 0= ?] N lda sp x) sta N 1+ lda sp )y sta next jmp end-code : cr< ?b (cr< ; : cr> ?e (cr> ; : pg< rows 0 DO cr< LOOP ; : pg> 1- rows 1- 0 DO cr> LOOP ; \\ : cr< ?b BEGIN 1- cr? UNTIL ; : cr> ?e BEGIN 1+ cr? UNTIL ; \ move-Base clv20jan88 : leftchars ( adr--adr u) dup dup cr< 1+ - ; : rightchars ( adr--adr u) dup 1- cr> over - ; : savCol dup dup cr< - col+ +! ; : useCol dup cr> over - col+ @ over - dup 0< IF + 0 THEN col+ ! + ; : noCol col+ off ; : cr? ( adr--adr flag) dup c@ #cr = ; : ?eL ?e dup 1- cr> fEnd @ - ?exit cr< ; \ executables clv20jan88 ( char adr-- char adr') : begLn noCol cr< 1+ ; : endLn noCol 1- cr> ; : up savCol cr< cr< useCol ; : down savCol 1- cr> ?eL useCol ; : lastPg savCol pg< useCol ; : nextPg savCol pg> ?eL useCol ; : begPg savCol drop scrBeg @ 1- useCol ; : endPg begPg nextPg ; : beg savCol drop fBeg @ 1- useCol ; : end savCol drop fEnd @ cr< useCol ; : right cr? IF 1 col+ +! ELSE 1+ THEN ; : left col+ @ IF -1 col+ +! ELSE 1- ?b THEN ; \ ..exe clv21jan88 : doChar col+ @ 0 ?DO bl fEmit LOOP noCol over fEmit ; : backDel col+ @ IF left ELSE 1 fDel THEN ; : delChar right backDel ; : wait BEGIN key? UNTIL ; : exitEd curPos ! drop exitRp @ rp! ; : info at? 5 0 at 2dup swap cr . . ." at" .i wait at ; : help tab @ BEGIN count WHILE dup @ >name .name 2+ REPEAT drop wait ; \ leer clv20jan88 \ writeFile clv20jan88 Onlyforth : writeFile 8 2 busopen fName count bustype " ,p,w" count bustype busoff derror? ?exit 8 2 busout 0 0 bus! bus! fBeg @ fEnd @ over - bustype busoff 8 2 busclose 0 (drv ! derror? ?exit ; : readFile 0 (drv ! 8 2 busopen fName count bustype " ,p,r" count bustype busoff derror? ?exit fBeg @ 8 2 busin bus@ drop bus@ drop BEGIN bus@ over c! 1+ $90 c@ UNTIL fEnd ! busoff 8 2 busclose derror? ?exit initroom ; \ leer clv20jan88 | : skp bus@ drop bus@ drop ; | : wrd bus@ bus@ $100 * + . ; | : str BEGIN bus@ ?dup WHILE emit REPEAT ; : files \ Filename kann folgen (drv @ 8 + dup 0 busopen " $0:" count bustype bl parse bustype " *" count bustype busoff derror? ?exit dup 0 busin skp skp \ Sector,Zeilenlink BEGIN cr wrd str skp $90 c@ UNTIL 0 busclose derror? ?exit ; \ leer clv20jan88 : fLine #tib @ >tib @ + 1+ dup fEnd @ u> IF drop rdrop exit THEN dup 1- cr> over - #tib ! >tib ! >in off ; : .fLine cr >tib @ dup 5 u.r space #tib @ type space ; : xx >tib push #tib push >in push r0 push ['] 'quit >body push ['] unnest Is 'quit ['] .status >body push rp@ r0 ! page ['] .fLine Is .status curPos @ >tib ! -1 #tib ! BEGIN fLine .status interpret REPEAT ; : loadFile curPos ! >r xx r> curPos @ wait ; \ leer clv20jan88 : fConvey ( [from to]--) 1+ swap curPos @ -rot ?DO rows 0 DO #cr fEmit J block I c/l * + c/l fType LOOP 1 fDel LOOP drop ; \ redraw show clv20jan88 : redraw BEGIN scrBeg @ fEnd @ over - scrCol @ .page drop drop over u< WHILE dup pg< 1+ scrBeg ! REPEAT ; ( adr--adr') : cursor \ dup curPos ! \ test scrBeg @ 1- -1 -rot BEGIN rot 1+ -rot cr> 2dup u> not UNTIL drop leftchars scrCol @ - rot swap col+ @ + 'at ; : ?sR? leftchars col+ @ + dup cols - 1+ scrCol @ max min scrCol ! ; : ?sB? dup scrBeg @ u< not ?exit dup begLn scrBeg ! ; : show ?sB? ?sr? redraw cursor ; \\ leer \\\\\\\\\\\\\\\\\\\\\ clv21jan88 \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ maintab clv21jan88 : A+ [compile] Ascii + ; : Ctr -$40 A+ ; : Cbm $60 A+ ; : Ct+ $40 A+ ; : => c, ' , ; Create maintab \ <key> c, ' word , Ctr ] => right Ct+ ] => left Ctr q => down Ct+ q => up Ctr u => begLn Ctr i => endLn Ctr h => begPg Ctr j => endPg Ctr g => lastPg Ctr k => nextPg Ctr b => beg Ctr n => end Ctr f => files Ctr l => loadFile Ctr c => exitEd Ctr t => backDel Ctr d => delChar Ctr w => writeFile Ctr r => readFile Ctr o => info Ctr p => help \ Ctr ? => redraw 0 => doChar \ 0 2 +thru \ editop clv20jan88 : dokey ( adr char --adr) tab @ 3 - BEGIN 3+ dup c@ WHILE 2dup c@ = UNTIL 1+ @ ( adr char cfa ) >r swap r> execute nip ; : editop rp@ exitRP ! \ fuer exitEd curPos @ BEGIN key? 0= IF show THEN key maintab tab ! dokey REPEAT ; \ edi3 test clv21jan88 : init limit $e000 u> abort" limit!!" 0 dup scrCol ! col+ ! limit 1+ dup scrBeg ! dup fBeg ! dup fEnd ! dup curPos ! drop $0d fBeg @ 1- c! initroom ; : red editop page ." end of edit" ; : edit bl parse $20 umin fName place init readFile red ; clv20jan88 \ editop clv13jan88 : dokey ( char--) tab @ 3 - BEGIN 3+ dup c@ WHILE 2dup c@ = UNTIL 1+ @ ( char cfa ) execute drop ; : (editop rp@ exitRp ! \ fuer exitEd BEGIN key dokey REPEAT ; : editop tab push maintab tab ! show \ Task initialisieren (editop noshow ; \ leer clv06jan88 0<><30>E$<24><07>%l<>' |