mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-03 07:05:57 +00:00
137 lines
8.4 KiB
Forth
137 lines
8.4 KiB
Forth
|
\ *** Block No. 0 Hexblock 0
|
||
|
|
\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87
|
||
|
|
|
||
|
|
Dieses File enthaelt Definitionen, die eine erweiterte Bild-
|
||
|
|
schirmdarstellung ermoeglichen:
|
||
|
|
|
||
|
|
- Installation eines Terminals mit Hilfe des Wortes
|
||
|
|
"Terminal:"
|
||
|
|
|
||
|
|
- Editieren von Eingabezeilen
|
||
|
|
|
||
|
|
In der Version 3.80a sind diese Teile aus dem Kern genommen
|
||
|
|
worden, um diesen einfacher zu gestalten.
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 1 Hexblock 1
|
||
|
|
\ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87
|
||
|
|
|
||
|
|
|
||
|
|
1 3 +thru \ Erweiterte Ausgabe
|
||
|
|
|
||
|
|
4 6 +thru \ Erweiterte Eingabe
|
||
|
|
|
||
|
|
|
||
|
|
' curon Is postlude
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 2 Hexblock 2
|
||
|
|
\ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87
|
||
|
|
| Variable terminal
|
||
|
|
|
||
|
|
: Term: ( off -- off' ) Create dup c, 2+
|
||
|
|
Does> c@ terminal @ + perform ;
|
||
|
|
|
||
|
|
: Terminal: Create: Does> terminal ! ;
|
||
|
|
|
||
|
|
0 Term: curon Term: curoff
|
||
|
|
Term: rvson Term: rvsoff
|
||
|
|
Term: dark Term: locate drop
|
||
|
|
|
||
|
|
: curleft ( -- ) at? 1- at ;
|
||
|
|
: currite ( -- ) at? 1+ at ;
|
||
|
|
|
||
|
|
Terminal: dumb noop noop noop noop noop 2drop ; dumb
|
||
|
|
\ *** Block No. 3 Hexblock 3
|
||
|
|
\ Erweiterte Ausgabe: UH 06Mar88
|
||
|
|
|
||
|
|
&80 Constant c/row &24 Constant c/col
|
||
|
|
|
||
|
|
| Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col
|
||
|
|
|
||
|
|
: (at ( row col -- ) c/row 1- min swap c/col 1- min swap
|
||
|
|
2dup 'at 2! locate ;
|
||
|
|
: (at? ( -- row col ) 'at 2@ ;
|
||
|
|
|
||
|
|
: (page ( -- ) 0 0 'at 2! dark ;
|
||
|
|
|
||
|
|
: (type ( addr len -- ) dup 'col +!
|
||
|
|
0 ?DO count (emit LOOP drop ;
|
||
|
|
|
||
|
|
: (emit ( c -- ) 1 'col +! (emit ;
|
||
|
|
\ *** Block No. 4 Hexblock 4
|
||
|
|
\ Erweiterte Ausgabe: UH 04Mar88
|
||
|
|
|
||
|
|
: (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ;
|
||
|
|
: (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ;
|
||
|
|
|
||
|
|
' (emit ' display 2+ !
|
||
|
|
' (cr ' display 4 + !
|
||
|
|
' (type ' display 6 + !
|
||
|
|
' (del ' display 8 + !
|
||
|
|
' (page ' display &10 + !
|
||
|
|
' (at ' display &12 + !
|
||
|
|
' (at? ' display &14 + !
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 5 Hexblock 5
|
||
|
|
\ Erweiterte Eingabe UH 08OCt87
|
||
|
|
| Variable maxchars | Variable oldspan oldspan off
|
||
|
|
|
||
|
|
| : redisplay ( addr pos -- )
|
||
|
|
at? 2swap under + span @ rot - type space at ;
|
||
|
|
| : del ( addr pos1 -- ) dup >r + dup 1+ swap
|
||
|
|
span @ r> - 1- cmove -1 span +! ;
|
||
|
|
| : ins ( addr pos1 -- ) dup >r + dup dup 1+
|
||
|
|
span @ r> - cmove> bl swap c! 1 span +! ;
|
||
|
|
|
||
|
|
| : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ;
|
||
|
|
| : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ;
|
||
|
|
| : (back ( a p1 -- a p2 ) 1- curleft (del ;
|
||
|
|
| : (recall ( a p1 -- a p2 ) ?dup ?exit
|
||
|
|
oldspan @ span ! 0 2dup redisplay ;
|
||
|
|
|
||
|
|
\ *** Block No. 6 Hexblock 6
|
||
|
|
\ Tastenbelegung fuer Zeilen-Editor CP/M UH 18Mar88
|
||
|
|
: (decode ( addr pos1 key -- addr pos2 )
|
||
|
|
4 case? IF dup span @ < 0=exit currite 1+ exit THEN
|
||
|
|
&19 case? IF dup 0=exit curleft 1- exit THEN
|
||
|
|
&22 case? IF dup span @ = ?exit (ins exit THEN
|
||
|
|
#bs case? IF dup 0=exit (back exit THEN
|
||
|
|
#del case? IF dup 0=exit (back exit THEN
|
||
|
|
7 case? IF span @ 2dup < and 0=exit (del exit THEN
|
||
|
|
$1B case? IF (recall exit THEN
|
||
|
|
#cr case? IF span @ dup maxchars ! oldspan !
|
||
|
|
dup at? rot span @ - - at space exit THEN
|
||
|
|
dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ;
|
||
|
|
|
||
|
|
: (expect ( addr len -- ) maxchars ! span off 0
|
||
|
|
BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ;
|
||
|
|
|
||
|
|
\ *** Block No. 7 Hexblock 7
|
||
|
|
\ Patch UH 08Oct87
|
||
|
|
|
||
|
|
: (key ( -- char )
|
||
|
|
curon BEGIN pause (key? UNTIL curoff getkey ;
|
||
|
|
|
||
|
|
' (key ' keyboard 2+ !
|
||
|
|
' (decode ' keyboard 6 + !
|
||
|
|
' (expect ' keyboard 8 + !
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|