1 line
32 KiB
Plaintext
1 line
32 KiB
Plaintext
\ Full-Screen Editor UH 02Nov86 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 Onlyforth cr 1 $1E +thru Onlyforth \ String primitves 27Nov87 : delete ( buffer size count -- ) over umin dup >r - 2dup over r@ + -rot cmove + r> bl fill ; : insert ( string length buffer size -- ) rot over umin dup >r - over dup r@ + rot cmove> r> cmove ; : replace ( string length buffer size -- ) rot umin cmove ; \ usefull definitions and Editor vocabulary UH 27Nov87 : blank ( addr len -- ) bl fill ; : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; : ?abort( ( f -- ) IF [compile] .( true abort" !" THEN [compile] ( ; Vocabulary Editor ' Forth | Alias F: immediate ' Editor | Alias E: immediate Editor also definitions \ move cursor with position-checking 23Nov86 | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; \\ : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses UH 31Oct86 | Code *line ( l -- adr ) H pop H dad H dad H dad H dad H dad H dad Hpush jmp end-code | Code /line ( n -- c l ) H pop L A mov $3F ani A E mov 0 D mvi L A mov ral A L mov H A mov ral A H mov L A mov ral A L mov H A mov ral A H mov L A mov ral 3 ani H L mov A H mov dpush jmp end-code \\ | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; \ calculate addresses UH 01Nov86 | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 01Nov86 | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab \ 1/4 line forth cursor $10 / 1+ $10 * cursor - c ; | : -tab \ 1/8 line back cursor 8 mod negate dup 0= 8 * + c ; | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; | : <cr> #after c ; \ show border UH 27Nov87&15 | Constant dx 1 | Constant dy | : horizontal ( row -- row' ) dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii | emit row dx c/l + at Ascii | emit 1+ LOOP ; | : border dy 1- horizontal vertical horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; Forth definitions : updated? ( -- f) scr @ block 2- @ 0< ; \ display screen UH 02Nov86 UH 27Nov87Editor definitions | Variable isfile' | Variable imode | : .updated ( -- ) 7 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at imode @ IF ." insert " exit THEN ." overwrite" ; | : .screen l/s 0 DO I redisplay LOOP ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id UH 02Nov86 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : get-id ( -- ) id c@ ?exit id on cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at id id-len 2 /string expect rvsoff span @ id 1+ c! ; \ update screen-display UH 02Dec86 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor UH 02Dec86 UH 23Feb88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot ( | Variable imode ) imode off | : setimode imode on .title ; | : clrimode imode off .title ; | : flipimode ( -- ) imode @ 0= imode ! .title ; | : done ( -- ) ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 03Nov86 UH 27Nov87 | Variable r#' r#' off | Variable scr' scr' off ( | Variable isfile' ) isfile@ isfile' ! | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens UH 06Mar88 ' name >body &10 + | Constant 'name | : showoff ['] exit 'name ! curoff rvsoff ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! curoff edit-at curon stop? IF showoff true Abort" Break! " THEN blk @ scr @ - IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon rvson ['] .status >body push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings UH 01Nov86 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." |" &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: |" 'find get swap 1+ swap 2- at ." ? replace: |" 'insert get ; \ search for string UH 02Nov86 UH 27Nov87 | : skip ( addr -- addr' ) 'find c@ + ; | : find? ( -- addr T | F ) 'find count 'cursor #remaining "search ; | : "find ( -- r# scr ) find? IF skip 'start - scr @ exit THEN ?stamp capacity scr @ 1+ ?DO 'find count I dup 5 5 at 4 .r block b/blk "search IF skip I block - I endloop exit THEN stop? Abort" Break! " LOOP true Abort" not found!" ; \ replace strings UH 03Nov86 UH 27Nov87| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at rvson type rvsoff ; | : (replace 'insert c@ 'find c@ - ?fit 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert 'insert c@ c modified ; | : "replace get-buffers BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Control-Characters and special keys CPCs UH 04Dec86Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate $7F Constant #del Editor definitions \ Definition der Spezialtasten $F0 | Constant #up $F1 | Constant #down $F2 | Constant #left $F3 | Constant #right $E0 | Constant #copy $FC | Constant #esc | ' 4+ | Alias &s ( key -- key' ) | : &c ( key -- key' ) 8 + ; \ Try a Screen-Editor for CPCs UH 04Dec86 Create keytable #up c, #left c, #down c, #right c, #up &s c, #left &s c, #down &s c, #right &s c, Ctrl Q c, Ctrl Z c, Ctrl H c, Ctrl H c, #del c, Ctrl P c, #copy c, Ctrl D c, Ctrl T c, Ctrl I c, Ctrl O c, Ctrl C c, Ctrl E c, #cr c, #right &c c, #left &c c, #up &c c, #down &c c, Ctrl F c, Ctrl U c, Ctrl X c, #esc c, Ctrl L c, Ctrl W c, Ctrl N c, Ctrl B c, Ctrl A c, Ctrl R c, here keytable - Constant #keys \ Try a screen Editor UH 28Nov86 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char copyline copychar backspace backspace backspace delete-char insert-char delete-line insert-line setimode clrimode clear-line clear> <cr> +tab -tab top >""end "replace undo update-exit flushed-exit showload >shadow n b a mark ; here actiontable - 2/ 1- #keys - ?abort( # of actions) \ find keys UH 01Nov86 | Code findkey ( key -- addr/default ) H pop L A mov keytable H lxi #keys $100 * D lxi [[ M cmp 0= ?[ actiontable H lxi 0 D mvi D dad D dad M E mov H inx M D mov D push next ]? H inx E inr D dcr 0= ?] ' putchar H lxi hpush jmp end-code \\ | : findkey ( key -- adr/default ) #keys 0 DO dup keytable F: I + c@ = IF drop E: actiontable F: I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 02Nov86| Variable jingle jingle on | : bell 07 con! jingle off ; | : clear-error jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit BEGIN ?clearbuffer edit-at key dup char c! findkey execute clear-error REPEAT ; | : fullerror ( string --) jingle @ IF bell THEN dy l/s + 1+ dx $16 + at rvson count type rvsoff &80 col - spaces scr @ capacity 1- min 0 max scr ! .title quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor UH 02Nov86 Forth definitions : v ( -- ) E: 'start drop get-id install ?clearbuffer page curoff border .all quit ; : l ( scr -- ) 1 ?enough scr ! E: top F: v ; \ savesystem UH 27Nov87 : savesystem \ save image E: id off (pad off savesystem ; | : >find ?clearbuffer >in push bl word count 'find 1+ place bl 'find 1+ dup >r count dup >r + c! r> 2+ 'find c! bl r> c! ; : view ( --) >find ' >name 4- @ (view ?dup 0= Abort" hand made" scr ! E: top curdown find? 0= IF ." From Scr # " scr @ u. true Abort" wrong file" THEN skip 'start - 1- r# ! v ; |