\ Full screen editor in forth-83. Based upon Henry 21Aug86 rsl
\ Laxen's original. MODIFIED FOR ANY COMPUTER. NO SHADOWS
\ Ported to x86 eForth by Andy Valencia 11/2001
\ -----------------------------***********************************
\ Craig A. Lindley * See screen 20 for help. *
\ Clockwork Software * SEE SCREEN 28 FOR MODIFICATIONS *
\ 6 Sutherland Place * AND UPDATES. *
\ Manitou Springs, Co. 80829 ***********************************
\ ----------------------------------------------------------------
\ Distributed by FIG Librarian (Please send updates)
\
\ John A. Peters Phone (415) 239-5393
\ 121 Santa Rosa Ave. 8-9 am or after 7 pm
\ San Francisco, CA 94112 or week ends.
\ ----------------------------------------------------------------
\ or Computer Language Mag. BBS (415) 957-9370 300/1200 (Files)
\ or Forth Interest Group Tree BBS (415) 538-3580 300 bps (Text)
only vocabulary editor
editor definitions
\ Configuration for ANSI terminal
: beep 7 emit ; \ Beep
\ Weird f83 stuff to emulate
: ctoggle ( u a -- ) \ Toggle bit in byte
dup c@ rot xor swap c! ;
: file? ." (block)" ; \ Display "file name"
\ Convert lower case to upper case
: upc ( c -- c ) dup 96 > over 123 < and if 32 - then ;
: at ( y x -- ) swap at-xy ;
\ this is another full screen editor program. it is written
\ entirely in high level forth. it is more convenient to use in
\ most cases as the starting forth editor.
\ vocabulary edit edit also definitions
variable &mode variable &cur \ var declaration
variable &badr variable &upd
variable &bbase
variable &status variable &tag
variable &id 12 allot &id 12 blank \ id field cleared
SCRSIZ constant cps BLKROWS constant lps
BLKCOLS constant c/l \ Chars in a line
cps 1 - constant cps-1 \ Some x-1 variants
lps 1 - constant lps-1
27 constant ESC \ ASCII escape char
: pad1 pad 84 + ; \ text save area
: pad2 pad1 84 + ; \ # input area
: >line# c/l / ; \ convert char pos to line #
: line#> c/l * ; \ convert line # to char pos
: curpos &cur @ ; \ get cursor position
: +cur &cur +! curpos \ adv cur and chk bounds
0 max cps-1 min &cur ! ;
: mvcur +cur curpos c/l /mod at ; \ move the cursor to pos on tos
: bufadr &badr @ + ; \ conv cur pos to buf addr
: bufpos curpos bufadr ; \ rets address in disk buf
\ of char at cur pos
: upd 1 &upd ! ; \ set update flag
: ?prt dup bl < swap 126 > or 0= ; \ chk char on tos
\ rets true if printable
: mark &upd @ if 0 &upd ! \ if block changed update
&id 0 bufadr c/l + 11 - 11 \ line 0
cmove update then ;
: #toeol c/l mod c/l swap - ; \ # chars to eol
: clreol curpos >line# line#> - blot ; \ clear to end of line
: bufmv rot bufadr rot bufadr \ move disk buffer
rot move upd ; \ @ cursor position
: distoeol dup bufadr over \ displays rest of line
#toeol -trailing \ from cur pos
rot over + >r type r> clreol ;
: position 0 0 at c/l blot ; \ Command input position
: unposition 0 0 at 0 distoeol ; \ Refresh display
: ?empty line#> bufadr c/l \ line # --- f
-trailing nip 0= ; \ rets true if line empty
\ : prnt position ." Printing" \ print on line printer
\ ['] (semit) is emit \ select lp as list device
\ printing on \ turn printing on
\ space cr space cr space cr \ 3 blanks lines between
\ scr @ list \ list to printer
\ ['] (emit) is emit \ select crt as list device
\ printing off \ turn printing off
\ key? if key drop then ; \ if abort consume key
: distoeos curpos swap lps swap \ display screen from line
do i line#> dup &cur ! \ # on tos to end
0 mvcur distoeol loop
&cur ! 0 mvcur ;
: exp dup dup c/l + cps over - \ insert blank line at
bufmv bufadr c/l blank ;
\ pos on tos
: shrink dup c/l + tuck cps \ del line at pos
swap - bufmv lps-1 line#> \ add blank line last
bufadr c/l blank ;
: insertline lps-1 ?empty \ adds line to screen
if dup exp >line# distoeos \ if last line is empty
else beep then ; \ else just beeps
: deleteline >line# dup line#> \ del line at pos
shrink distoeos ; \ on tos
: inschar dup dup 1+ over #toeol \ insert char into buf
1 - bufmv bufadr c! ;
: delchar dup dup 1+ tuck \ del char at cursor
#toeol bufmv dup #toeol +
1- bufadr bl swap c! ;
: rarrow 1 +cur ; \ cursor right one
: larrow -1 +cur ; \ cursor left one
: uarrow c/l negate +cur ; \ cursor up one
: darrow c/l +cur ; \ cursor down one
: iline curpos insertline ; \ insert line at cur
: dline curpos deleteline ; \ delete line at cur
: dchar curpos delchar curpos \ delete char at cursor
distoeol ;
: imode 1 &mode ctoggle \ toggle insert mode flag
1 &status ! ;
: heading page \ heading titles
26 0 at ." *** Forth Full Screen Editor ***"
0 1 at ." File: " file? ;
: ret &mode @ if iline else \ insert mode insert line
curpos >line# 1+ lps-1 min \ if not just do return
line#> &cur ! then ;
: quited heading cr cr forth \ quit editor without
." Edit session complete" \ saving screens. Resets
cr sp0 @ sp! quit ; \ stack and executes quit
: exitupd mark save-buffers quited ; \ save screens before
\ quiting editor
: #in pad2 1+ 20 2dup blank expect \ input a # from the user
span @ pad2 c! pad2 number? drop ; \ to the tos
: dupblock position \ duplicate block at
." Duplicate block #: " #in ?dup \ specified location
if scr @ swap copy then \ answer 0 then abort
unposition ;
: deltoeos bufpos dup &badr @ - \ delete from cursor to
1+ cps swap - blank
curpos >line# distoeos upd ; \ the end of the display
: scan+= 2dup = if drop drop drop 0 else 0 -rot
do over i c@ = if leave else 1+ then loop
nip then ;
: scan+<> 2dup = if drop drop drop 0 else 0 -rot
do over i c@ <> if leave else 1+ then loop
nip then ;
: scan-= 2dup = if drop drop drop 0 else 0 -rot
do over i c@ = if leave else 1- then -1 +loop
nip then ;
: scan-<> 2dup = if drop drop drop 0 else 0 -rot
do over i c@ <> if leave else 1- then -1 +loop
nip then ;
: mvlwrd bl 0 bufadr bufpos \ move left a word
scan-= >r bl 0 bufadr \ rets # of chars to move cur
bufpos r@ + scan-<> r> + ;
: mvrwrd bl cps-1 bufadr \ move right a word
bufpos scan+= >r bl cps-1 \ rets # of chars to move cur
bufadr bufpos r@ +
scan+<> r> + ;
: rword mvrwrd +cur ; \ move cur right one word
: lword mvlwrd +cur ; \ move cur left one word
: delchars 2dup + over dup \ delete n chars from cur
#toeol bufmv dup #toeol
+ over - bufadr swap blank ;
: dword mvrwrd bufpos curpos \ delete word at cur
#toeol -trailing
nip min curpos
delchars curpos distoeol ;
: tab 8 curpos 8 mod - +cur ; \ advance to tab position
: updscr 0 distoeos ; \ display screen
: clrscn 0 &cur ! bufpos cps \ clear screen
blank 0 distoeos upd ;
: clrline curpos dup >line# \ set current line to blanks
line#> &cur ! bufpos c/l
blank upd 0 mvcur curpos
clreol &cur ! ;
: getid &id 12 -trailing 0= \ input user id
if cr ." Enter id: "
12 0 do 46 emit loop
12 0 do 8 emit loop
&id 12 expect
else drop then ;
: init2 \ initialize editor but not blocks
1 &status ! 0 &mode ! 0 &cur !
page updscr ;
: init mark scr @ \ initialize block buffer, then rest of edit
block dup &badr ! &bbase ! init2 ;
: edits position \ prompt for edit block
." Edit scr#: " #in
scr ! init ;
: rstedit discard \ restart edit
0 &upd ! init ;
: lstblk scr @ dup 0> \ get last block
if 1- scr ! init then ;
\ : nxtblk scr @ dup capacity 1- < \ get next block
\ if 1+ scr ! init then ;
: nxtblk 1 scr +! init ;
\ Alternate between shadow and main screen
\ A ForthOS block is 4k, and a screen is just shy of 2k. So
\ we use the first half of the block for the source, and the
\ second as a shadow.
: edtshdw curpos &badr @ &bbase @ = if SCRSIZ &badr +!
else &bbase @ &badr ! then init2 +cur ;
\ Wait "a while". TBD: get ForthOS clock services, and use them!
: delay 4000000 0 do loop ;
\ this screen code is used to set the user defined tag
: settag position
." Tag set" delay
scr @ &tag ! unposition ;
: totag &tag @ scr ! init ;
: help heading cr ." Normal commands" cr cr
." ^Q-clr line ^Y-del line ^P-get line" cr
." ^K-del to eol ^O-put line ^L-del to eos" cr
." ^I-tab ^U-update scr ^T-del word" cr
." ^G-del char ^V-insert mode ret-insert line" cr
." ^C-next scr ^R-last scr ^J-goto tag" cr
." ^E-up ^X-down ^S-left" cr
." ^D-right ^A-left word ^F-right word" cr
." ^B-begin line ^N-end line" cr cr
." Special commands (used after the esc key):" cr cr
." c-clr scr d-dup blk e-edit scr" cr
." f-finished p-print scr q-quit edit" cr
." r-restart s-edit shadow t-set tag" cr
." h-help" cr cr
." Hit any key to continue" key drop 1 &status !
page updscr ;
: 1st 0 &cur ! ; \ go to 1st line
: lst lps-1 line#> &cur ! ; \ go to last line
: hldln curpos >line# line#> \ hold line at cur
bufadr pad1 c/l cmove \ at pad
1 &status ! ;
: insln lps-1 ?empty if curpos \ insert line from pad
>line# dup line#> dup \ at cur
exp bufadr pad1 swap c/l
cmove distoeos
else beep then ;
: rett &mode @ \ special cr never inserts
0 &mode ! ret \ blank line even if
&mode ! ; \ insert is on
: begline rett uarrow ; \ goto beg of line
: endline rett -1 +cur bl \ goto last char of line
bufpos dup c/l - swap
scan-<> 1+ +cur ;
: deltoeol curpos #toeol dup \ delete to end of line
\ vandys
spaces bufpos
swap blank upd ;
: status \ display edit status
page
curpos c/l /mod 15 \ display line and char
64 2 at 2 .r \ positions
73 2 at 2 .r
&status @ if \ if status change then
14 2 at scr @ 3 .r \ display remainder
28 2 at &upd @
if inv-on ." Altered" inv-off else ." Virgin " then
45 2 at &mode @
if inv-on ." Insert on " inv-off else ." Insert off" then
8 21 2dup at 8 blot at pad1 c/l -trailing type
0 &status ! then
0 3 at ." Hit a key to continue: " key drop page updscr ;
: & [compile] char [compile] literal ; immediate \ shorthand for char
: special position ." Special cmd: " \ process control chars
0 1500000 0 \ put 0 on tos as flag
do key? if drop 1 leave then loop \ loop until key or
\ tos 0 if time out
if key upc case \ if key then show it
\ and process
& E of edits endof & R of rstedit endof & C of clrscn endof
\ & P of prnt endof
& H of help endof & V of status endof
& D of dupblock endof & Q of quited endof
& F of exitupd endof & S of edtshdw endof & T of settag endof
beep endcase
else help \ else show help menu
then
unposition \ Refresh prompt line
1 &status ! 0 mvcur ; \ update screen
\ Shorthand for compiling a control character into a def
: ^ [compile] char $1F and [compile] literal ; immediate
: command case
^ Q of clrline endof ^ Y of dline endof ^ O of insln endof
^ H of larrow endof ^ N of endline endof ^ K of deltoeol endof
^ M of ret endof ^ P of hldln endof ^ L of deltoeos endof
^ I of tab endof ^ U of updscr endof ^ T of dword endof
ESC of special endof ^ B of begline endof ^ J of totag endof
^ E of uarrow endof ^ R of lstblk endof ^ S of larrow endof
^ D of rarrow endof ^ Z of lst endof ^ X of darrow endof
^ C of nxtblk endof ^ V of imode endof ^ G of dchar endof
^ A of lword endof ^ F of rword endof ^ W of 1st endof
beep endcase ;
: insertoff key dup ?prt \ overlay char at cursor
if dup emit bufpos c! upd 1 +cur
else command then ;
: inserton key dup ?prt \ insert char at cursor
if curpos inschar curpos
distoeol 1 +cur
else command then ;
also forth definitions
: e decimal empty-buffers \ invoke editor with e
depth if scr ! then \ if screen specified then
scr @ &tag ! \ set tag to 1st screen
0 &cur ! 0 &mode ! 0 &upd ! \ reset variables
pad 200 blank \ clear pad area
heading cr cr
." Ready when you are" cr cr \ display message
getid init \ initialize editor
begin \ main editor loop
0 mvcur &mode @
if inserton else insertoff then
again ; \ loop forever
only