|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 175104 (0x2ac00)
Types: TextFile
Names: »se40txt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »se40txt «
program se(output,infile,outfile,regfile,parmfile,exefile);
(* * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Screen Editor for RC8000 using type 2 set up *)
(* in terminal drivers. (3600, ACP, CSP) *)
(* *)
(* A/S Regnecentralen *)
(* Henning Godske 890101 *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * *)
(****************************************************)
(* Revision history *)
(*--------------------------------------------------*)
(* 85.09.09 Release 1.00 version 1 *)
(* 86.03.18 Release 1.1 version 1 *)
(* 86.04.03 Release 2.0 version 1 *)
(* 87.11.30 Release 3.0 version 1 *)
(* Rewriting of most of the code *)
(* Variable ect. added *)
(* 88.04.22 Release 3.1 *)
(* Errors corrected: *)
(* get_string with , . ; and space *)
(* sense now using own message var *)
(* break set in find if not typeah.*)
(* New com. SP start position *)
(* Save WRK file at error terminate*)
(* Output buffer set down to 512 *)
(* 88.10.20 Release 4.0 *)
(* RC9000-10 now included *)
(* Terminal is reserved, *)
(* Error in justifyline fixed. *)
(* No file swop at JT if no update *)
(* Scroll up if ANSI implement. *)
(****************************************************)
(*$t-*)
label 99;
const
sw_nr = "RC8000 / RC9000-10 Screen Editor$";
release = " Release 4.0";
reldate = "890101#";
versionnumber = 890101; (* Versionnumber for parameterfile *)
halfsinword = 2;
charsinword = 3;
bufsize = 512; (* Bufsize for output *)
linesize = 81; (* Max. char. in a line *)
maxreg = 10; (* Max. registers *)
maxwindowsize = 4000; (* Max. windowsize *)
minsize = 85000; (* Min. process size for this version *)
maxlevel = 10; (* Max. level in commands *)
lineconcat = '+'; (* Line concatenation char *)
ffdisplay = '#'; (* Form feed char *)
nldisplay = '<'; (* New line char *)
controlch = '@'; (* Control char *)
(* register error texts *)
unknownregister = "Unknown register $";
nomoreregisters = "No more registers $";
registerexists = "Register exist $";
filenonexisting = "File does not exist $";
cannotcreatereg = "Cannot create register $";
type
iso_alfa = packed array Æ1..alfalengthÅ of iso;
controltype = (moveleft, eraseeol, eraseeos, cursorset,
invon,invoff,highon,highoff,cursorup);
insertkind = ( insertfile, insertlinekind, insertnl,
insertff, blockline, blockoverwrite);
updatetype = ( noupdate, partialupdate, allupdate );
conv_type = ( mode_3600, mode_csp, mode_csp_force);
outbuf = packed arrayÆ1..bufsizeÅ of iso;
text40 = packed arrayÆ1..40Å of iso;
linie= packed arrayÆ1..linesizeÅ of iso;
unpackedline= arrayÆ1..linesizeÅ of iso;
linerec=
record
l: linie;
attribute: iso;
linelength: integer;
end;
lineptr= ^linerec;
io_message=
record
operation: integer;
first: integer;
last: integer;
x0, x1, x2, x3, x4: integer; (* unused *)
end;
io_answer=
record
status: integer;
bytes_trans: integer;
char_trans: integer;
x0, x1, x2, x3, x4: integer; (* unused *)
end;
linespec=
packed record
operation: integer; (* word 0 *)
dummy0: 0..255; (* word 1 *)
conversion: boolean;
continued: 0..3;
echo: 0..3;
softparity: boolean;
ttype: 0..1023;
attention: 0..7; (* word 2 *)
dummy2: 0..2097151;
dummy3: 0..255; (* word 3 *)
prompt: iso;
dummy4: 0..255;
dummy5: integer; (* word 4 *)
dummy6: integer; (* word 5 *)
timer: 0..65535; (* word 6 *)
dummy7: 0..255;
d1 : 0..255; (* word 7 *)
d2 : 0..1;
fc : 0..3;
s : 0..1;
p : 0..3;
l : 0..3;
rsp : 0..15;
xsp : 0..15;
end;
nameaddress=
record
procname: alfa;
nametable: integer;
end;
tailtype=
record
size: integer;
document: alfa;
resttail: arrayÆ6..10Å of integer;
end;
entrybase=
record
lowerbase: integer;
upperbase: integer;
end;
headtailtype=
record
key: integer;
base: entrybase;
entryname: alfa;
tail: tailtype;
end;
baselevel = (stdbase,userbase,maxbase);
basearray = arrayÆbaselevelÅ of entrybase;
zoneindex = (curin,curout);
isofile = file of iso;
var
commands : arrayÆ-1..255Å of linerec; (* controlkey commands *)
bases : basearray; (* Process bases *)
conv_state : conv_type; (* Type of terminal conversion *)
c, (* Global count variable *)
xr_line, (* Line counter for xr command *)
scroll, (* Scroll counter for updating screen *)
scroll_up, (* Scroll counter for updating screen *)
count, (* Global command counter *)
insertline, (* Current line in insertmode *)
lastinbuf, (* Pointer to last char. in input buffer *)
nextinbuf, (* Pointer to next char in input buffer *)
lastobuf, (* Pointer to last char. in output buffer *)
nextobuf, (* Pointer to next char in output buffer *)
lastinline, (* Max. number of char in screen line *)
statusline, (* Screen linenumber for statusline *)
windowsize, (* Numbers of lines in window *)
displaysize, (* Numbers of lines on screen for displaying text *)
windowstart, (* First line used in window at start *)
firstwindow, (* First line used in window at this time *)
lastwindow, (* Last line used in window at this time *)
firstdisplay, (* First line from window on screen *)
lastdisplay, (* Last line from window on screen *)
firstupdate, (* First line to be updated next time *)
lastupdate, (* Last line to be updated next time *)
permkey, (* Permanet key for result file *)
curx, (* Current x position in text *)
cury, (* Current y position in text (relativ to window) *)
storedline, (* Number of lines stored in top of window *)
overlap, (* Number of overlapping lines when updating new page *)
convtabnr, (* Convert table used in amx driver *)
level, (* Command level counter *)
outch, (* Char. out count *)
i, (* Global counter variable *)
j : integer;
timeout, (* Timeout for ! and $ repeating commands in seconds *)
normaltimeout (* Timeout for count repeating commands *)
: real;
cancel, (* Value of cancel key *)
it_del, (* Delimitor for insert text *)
prefix, (* Key value for prefix key *)
ci, (* Value for control intruducer *)
ch (* Global char. variable *)
: iso;
comm: linie; (* Commandline for simplecommands *)
it, (* Insert mode *)
id, (* Indent mode *)
nlm, (* New line mark *)
st_change, (* Statusline changed *)
line_ex, (* Line is extented *)
mark_overwrite, (* Mark is overwrited *)
nooutfile, (* No output file (resultfile) *)
noinfile, (* No input file (editfile) *)
backedup, (* There have been a backup *)
cursorupdate, (* Update cursor position *)
oddtempfile, (* Odd tempfile for output *)
typeahead, (* Typeahead active *)
exittest, (* Exittest active *)
linenumber, (* Linenumbers included on screen *)
xr, (* Executing register *)
echo, (* Echo input in getnext *)
one_char, (* Input one char at the time *)
break, (* Stop executing command *)
cont, (* Repeating using $ *)
tc, (* Text changed *)
file_updated, (* Text changed since last jt *)
no_par, (* No parameter to the command *)
next_com, (* Go on with next command *)
error_start, (* Error recovery started *)
go_on (* Go on executing command *)
: boolean;
iline, (* Input buffer line *)
findline, (* Line used for find command *)
templine, (* Global temp. line *)
subfindline, (* Line used for substitute find command *)
subinsertline (* Line used for substituting *)
: lineptr;
filewindow (* Array of pointers to lines in window *)
: arrayÆ0..maxwindowsizeÅ of lineptr;
smsg, (* Sense message *)
imsg, (* Input message *)
omsg (* Output message *)
: io_message;
sans, (* Sense answer *)
ians, (* Input answer *)
oans (* Output answer *)
: io_answer;
oline (* Pointer to output buffer *)
: ^outbuf;
localtermmsg, (* Local setup for front end *)
termmsg (* Normal setup for front end *)
: linespec;
curinname, (* name of process to send terminal input *)
curoutname (* name of process to receive terminal output *)
: nameaddress;
tabline (* Tabulator line *)
: ^linerec;
localline : linie; (* work *)
uplocalline : unpackedline; (* work *)
values (* Variable indeholdende tal eller tekst *)
: arrayÆ0..9Å of linerec;
controls (* Array of control sequences *)
: arrayÆcontroltypeÅ of
record
ctrl: packed arrayÆ1..9Å of iso;
length: integer;
end;
updatestate (* State of next screen updating *)
: updatetype;
infile, (* Input file (editfile) *)
outfile, (* Output file (resultfile) *)
regfile, (* Files used for registers *)
exefile, (* File used for execute register *)
parmfile (* Parameter file *)
: isofile;
inname, (* Name of input file *)
outname, (* Name of output file *)
programname, (* Work name *)
ename, (* Editor name *)
pname, (* Name used for error message *)
tempname1, (* Workname 1 *)
tempname2, (* Workname 2 *)
alf (* Global alfa name *)
: alfa;
defaultreg, (* Default register name *)
sesavename, (* Name of error save file *)
nullalfa (* empty alfa name *)
: iso_alfa;
canceltxt : text40;
filebase (* File base array *)
: entrybase;
regnames (* Register descrip. array *)
: arrayÆ1..maxregÅ of
record
reg, fil: alfa;
local: boolean;
end;
worddelimit (* Word delimitors *)
: set of iso;
flags (* Line number memory *)
: arrayÆ0..9,0..1Å of integer;
value
defaultreg = ('d','e','f','a','u','l','t',nul,nul,nul,nul,nul);
sesavename = ('s','e','e','r','r','o','r','s','a','v','e',nul);
nullalfa = (nul,nul,nul,nul,nul,nul,nul,nul,nul,nul,nul,nul);
linenumber =false;
it =false;
id =false;
nlm =false;
st_change =false;
backedup =false;
line_ex =false;
mark_overwrite =false;
tc =false;
file_updated =false;
next_com =false;
go_on =true;
break =false;
cont =false;
xr =false;
storedline = 0;
level =0;
scroll =0;
scroll_up =0;
external module mmonitor;
(*$r+*)
function sendmessage(var name: nameaddress;
var msg: linespec): integer;
function waitanswer(buf: integer; var a: linespec): integer;
function sendwait(var name: nameaddress;
var msg: io_message;
var a: io_answer): integer;
(*$r-*)
function createentry(var filename: alfa; var t: tailtype): integer;
function lookupentry(var filename: alfa; var t: tailtype): integer;
function lookheadtail(var filename: alfa; var ht: headtailtype): integer;
function renameentry(var filename: alfa; var newname: alfa): integer;
function removeentry(var filename: alfa): integer;
function reserveproc(var filename: alfa): integer;
function releaseproc(var filename: alfa): integer;
function createproc(var filename: alfa): integer;
function getsize:integer;
function permentry(var filename: alfa; permkey: integer): integer;
function setentrybase(var filename: alfa; base: entrybase): integer;
procedure getscopebase(var base: basearray);
function getcurname(var a: alfa; z: zoneindex):integer;
procedure parent(var name: alfa);
function claims:integer;
procedure exit;
end (* monitor *)
external module pascalhalt;
procedure halt(b: boolean);
end (* pascalhalt *)
external module mreadline;
(*$r+*)
procedure readline(var f: isofile;
var l: unpackedline;
var chars: integer;
max: integer);
procedure skipchar(var f: isofile);
(*$r-*)
end (* mreadline *)
(*$r+*)
procedure command( cline:linie;
last:integer);
forward;
procedure putch(ch: iso);
forward;
procedure putchnewbuf(ch: iso);
forward;
procedure puthl(t40: text40);
forward;
procedure putinv(t40: text40);
forward;
procedure putcursor(x,y: integer; newbuf: boolean);
forward;
procedure putdisplay;
forward;
procedure putcontrol( c: controltype; newbuf : boolean);
forward;
procedure clearstatusline;
forward;
(*$r-*)
procedure justifydisplay;
forward;
procedure setterminal(normal: boolean; t : integer; echo_off:boolean);
forward;
procedure jumptop;
forward;
(*$r+*)
procedure linedown;
forward;
procedure lineup;
forward;
(*$r-*)
procedure jumpline(line:integer;just:boolean);
forward;
procedure attention(text: text40);
forward;
function query(t40: text40): iso;
forward;
function getnumber(cline: linie;
var clinechar:integer; text:text40):integer;
forward;
function getline(var comm:linie):integer;
forward;
procedure get_string(cline:linie; var clinechar:integer;
text:text40; var string:linerec;
var sep:boolean);
forward;
procedure stopinsert(all:boolean);
forward;
procedure closefiles(permkey: integer;
base: entrybase; var tail: headtailtype);
forward;
procedure writefile;
forward;
procedure terminate;
var i : integer;
begin
i:=releaseproc(inname);
setterminal(true,0,false);
putchnewbuf(nl);
i:=releaseproc(curinname.procname);
if exittest then
begin
writeln("Release date ",reldate);
goto 99;
end
else
exit;
end;
procedure error(t: text40; i: integer);
var tail : headtailtype;
begin
if not error_start then
begin
i:=releaseproc(curinname.procname);
error_start := true;
outname:= sesavename;
writefile;
closefiles(3,basesÆuserbaseÅ,tail);
putcontrol(eraseeos,true);
writeln(pname," Internal or hard error: ");
write(t,i:4);
writeln(bel,bel);
writeln(pname," Text saved in file: ",outname," (if possible)");
writeln(pname," Terminal has been reset !");
setterminal(true,0,false);
writeln(pname," Dump of internal editor calls : ");
end;
halt(true);
end;
procedure setterminal(normal: boolean; t : integer; echo_off:boolean);
var
buf,i: integer;
conversion: boolean;
prompt: iso;
ans: linespec;
begin
if normal then
with termmsg do
begin
if (prompt=nul) then
begin
attention:=0;
ttype:=1;
prompt:=bel;
timer:=60;
continued:=0;
end;
operation:=132*4096; (* new set term sepc *)
buf:= sendmessage(curinname,termmsg);
if buf=0 then
error("Set term spec. message ",1);
i:= waitanswer(buf,ans);
if i<>1 then
begin
operation:=4*4096;
buf:= sendmessage(curinname,termmsg);
if buf=0 then
error("Set term spec. message ",2);
i:= waitanswer(buf,ans);
if i<>1 then
begin
error("Set term spec. message ",3);
end;
end;
end
else
with localtermmsg do
begin
localtermmsg:=termmsg;
if typeahead then
begin
attention:=1;
if echo_off then
echo:=0
else
echo:=1;
continued:=1;
end;
if conv_state = mode_3600 then
ttype := convtabnr
else
ttype := 2;
conversion:=false;
prompt:=nul;
timer:=t;
operation:=132*4096; (* new set term sepc *)
buf:= sendmessage(curinname,localtermmsg);
if buf=0 then
error("Set term spec. message ",3);
i:= waitanswer(buf,ans);
if i<>1 then
begin
operation:=4*4096;
buf:= sendmessage(curinname,localtermmsg);
if buf=0 then
error("Set term spec. message ",4);
i:= waitanswer(buf,ans);
if i<>1 then
begin
error("Set term spec. message ",5);
end;
end;
end;
end;
function lookahead: iso;
begin
if nextinbuf>=lastinbuf then
lookahead:= del
else
lookahead:= iline^.lÆnextinbuf+1Å;
end;
function getnext: iso;
label 1;
var
char: iso;
result: integer;
begin
1:
if nextinbuf>=lastinbuf then
begin
echo:=false;
if one_char then
imsg.last:=ord(iline)
else
imsg.last:= ord(iline)+(abs(lastinline-curx)
div charsinword)*halfsinword;
repeat
result:= sendwait(curinname,imsg,ians);
if result<>1 then
error("Input sendwait ",result);
lastinbuf:= ians.char_trans;
if lastinbuf>linesize then
lastinbuf:=linesize;
nextinbuf:= 1;
if (ians.status = 65536) then
begin (* Attention *)
clearstatusline;
puthl("Cancel $");
lastinbuf:=1;
nextinbuf:=1;
iline^.lÆ1Å:=cancel;
if cancel <> esc then
updatestate:=allupdate;
end
else
if ((ians.status=0) and (ians.char_trans=0)) then
begin (* Tas system menu attention *)
updatestate:=allupdate;
lastinbuf:=1;
iline^.lÆnextinbufÅ:=cancel;
putdisplay;
putcursor(curx,cury-firstdisplay+1,true);
end;
until lastinbuf>0;
end
else
nextinbuf:= nextinbuf + 1;
with iline^ do
begin
if lÆnextinbufÅ>chr(127) then
char:=chr(ord(lÆnextinbufÅ)-128)
else
char:=lÆnextinbufÅ;
end;
if echo and (char>us) and (char<del) then
if nextinbuf=lastinbuf then
putchnewbuf(char)
else
putch(char);
if (char = nul) and (ci <> nul) then
goto 1;
if char in Ænul..us,delÅ then
lastinbuf:=nextinbuf;
getnext:= char;
end;
function get_key_number:integer;
label 1;
var val: integer;
hold_bool: boolean;
ch: iso;
begin
val:=0;
hold_bool:=one_char;
one_char:=true;
ch:=getnext;
lastinbuf:=nextinbuf;
if ch in Æ'0'..'9'Å then
begin
val:=ord(ch)-ord('0');
ch:=getnext;
if (ch=del) or (ch=bs) then
begin
putcontrol(moveleft,false);
putch(' ');
putcontrol(moveleft,true);
val:=0;
ch:=getnext;
end;
while (ch in Æ'0'..'9',bs,delÅ) do
begin
if val>99999 then
goto 1
else
if ch in Æ'0'..'9'Å then
val:=val*10+(ord(ch)-ord('0'));
ch:=getnext;
if (ch=del) or (ch=bs) then
begin
putcontrol(moveleft,false);
putch(' ');
putcontrol(moveleft,true);
val:=val div 10;
ch:=getnext;
end;
end;
while ch<>cr do
ch:=getnext;
end
else
begin
if (ch>us) and (ch<del) then
goto 1;
if ch=prefix then
begin
val:=128;
ch:=getnext;
if (ch>us) and (ch<del) then
goto 1;
end;
while ch=ci do
begin
val:=val+32;
ch:=getnext;
if (ch>us) and (ch<del) then
goto 1;
end;
if ch=del then
ch:=nul;
val:=val+ord(ch);
end;
if val>255 then
begin
1: lastinbuf:=0;
nextinbuf:=0;
val:=-1;
one_char:=hold_bool;
attention("Illegal key $");
end;
get_key_number:=val;
one_char:=hold_bool;
end;
function sense: boolean;
label 1,2;
var
s: boolean;
ch: iso;
result: integer;
begin
if nextinbuf>=(linesize-4) then
begin
attention("Overflow on input ");
updatestate:=allupdate;
nextinbuf:=0;
lastinbuf:=0;
sense:=true;
goto 1;
end;
sense:=false;
echo:=true;
if conv_state <> mode_csp_force then
setterminal(false,1,true);
if nextinbuf>=lastinbuf then
begin
lastinbuf:=0;
nextinbuf:=0;
end;
smsg.first:= ord(iline)+(abs(lastinbuf+2) div charsinword)*halfsinword;
smsg.last := ord(iline)+abs((linesize div charsinword)*halfsinword-2);
result:= sendwait(curinname,smsg,sans);
if result<>1 then
error("Sense sendwait ",result);
s:=false;
if conv_state <> mode_csp_force then
setterminal(false,60,false);
if (sans.char_trans>0) or (sans.status = 65536) then
begin
updatestate:=allupdate;
if sans.char_trans>0 then
begin
lastinbuf:=((lastinbuf+2) div charsinword)*charsinword+sans.char_trans;
if iline^.lÆlastinbufÅ=cancel then
s:=true;
end;
if sans.status = 65536 then
s:=true;
if s then
begin
lastinbuf:=0;
updatestate:=allupdate;
putdisplay;
2: putch(bel);
ch:=query("Interrupted. Continue command ? (no) #");
if (ch=cr) or (ch="N") or (ch="n") or (ch=so) or (ch=cancel) then
begin
if ch=cancel then
goto 2;
go_on:=false;
break:=true;
sense:=true;
end
else
begin
clearstatusline;
puthl("Command continued. Please wait#");
end;
end;
end;
1:
end;
procedure getalfa(cline: linie; var c:integer; var alf:alfa; text:text40);
var
j,i: integer;
begin
no_par:=false;
i:=1;
while (clineÆcÅ=' ') do
c:=c+1;
if (clineÆcÅ='&') or (clineÆcÅ='%') then
begin
if clineÆcÅ='&' then
begin
clearstatusline;
putch(bel);
puthl(text);
i:=getline(templine^.l);
c:=c+1;
end
else
begin
c:=c+1;
i:=getnumber(cline,c,"Variable number: $");
if i>9 then
begin
attention("Illegal variable number$");
i:=0;
go_on:=false;
end
else
templine^.l:=valuesÆiÅ.l;
end;
i:=1;
getalfa(templine^.l,i,alf,text);
end
else
begin
while not(clineÆcÅ in Ænul..us,del,' ',',',';','.'Å) do
begin
if i<=alfalength then
alfÆiÅ:=clineÆcÅ;
c:=c+1;
i:=i+1;
end;
if clineÆcÅ = ';' then
clineÆcÅ:=cr;
if i>alfalength then
i:=alfalength;
for j:=1 to (i-1) do
if alfÆjÅ in Æ'A'..'Å'Å then
alfÆjÅ:=chr(ord(alfÆjÅ)+32);
for j:=i to alfalength do
alfÆjÅ:=chr(0);
if alf=nullalfa then
no_par:=true;
if clineÆcÅ = cancel then
begin
break:=true;
go_on:=false;
end;
end;
for j:=1 to alfalength do
if (alfÆjÅ in Æsoh..'@','^'..'`','ü'..delÅ) then
if not((j>1) and (alfÆjÅ in Æ'0'..'9'Å)) then
begin
alf:=nullalfa;
attention("Illegal name or parameter$");
break:=true;
go_on:=false;
end;
end;
(*$r+*)
procedure putchnewbuf(ch: iso);
label 1;
var
hw,start,result: integer;
begin
1:
outch:=outch+nextobuf;
if conv_state = mode_3600 then
begin
if (ch<=us) and (ch<>nl) then
ch:=chr(ord(ch)+128);
end;
oline^Ænextobuf+0Å:= ch;
oline^Ænextobuf+1Å:= nul;
oline^Ænextobuf+2Å:= nul;
hw:=((nextobuf+2) div charsinword)*halfsinword;
start:=0;
repeat
omsg.first:= ord(oline)+start;
omsg.last:= omsg.first+hw-2;
result:= sendwait(curoutname,omsg,oans);
if result<>1 then
error("Output sendwait ",result);
if oans.status=65536 then
goto 1 (* Gentag output ved attention *)
else
begin
hw:=hw-oans.bytes_trans;
start:=start+oans.bytes_trans;
end;
until hw=0;
nextobuf:= 1;
end;
procedure putch(ch: iso);
begin
if nextobuf>(bufsize-3) then
putchnewbuf(ch)
else
begin
if conv_state = mode_3600 then
begin
if (ch<=us) and (ch<>nl) then
ch:=chr(ord(ch)+128);
end;
oline^ÆnextobufÅ:= ch;
nextobuf:= nextobuf + 1;
end;
end;
procedure putcontrol( c: controltype; newbuf : boolean);
var
i: integer;
begin
with controlsÆcÅ do
if length>0 then
begin
for i:=1 to length-1 do
putch(ctrlÆiÅ);
if newbuf then
putchnewbuf(ctrlÆlengthÅ)
else
putch(ctrlÆlengthÅ);
end
else
if newbuf then
putchnewbuf(nul);
end;
(*$r-*)
procedure putalfa(a: alfa; hl:boolean);
var
ch: iso;
i: integer;
begin
if hl then
putcontrol(highon,false);
i:= 1;
ch:= aÆiÅ;
while (ch<>'#') and (ch<>' ') and (ch<>nul) and (i<alfalength) do
begin
if (ch<' ') and (ch<>nl) then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
if not hl then
putcontrol(highoff,false);
end
else
putch(ch);
i:= i+1;
ch:= aÆiÅ;
end;
if ch<>'#' then
if (ch<' ') and (ch<>nl) and (ch<>nul) then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
if not hl then
putcontrol(highoff,false);
end
else
putch(ch);
if hl then
putcontrol(highoff,false);
end;
procedure put40(t40: text40);
var
ch: iso;
i: integer;
begin
i:= 1;
ch:= t40ÆiÅ;
while (ch<>'#') and (ch<>'$') and (i<40) do
begin
if ch<' ' then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(ch);
i:= i+1;
ch:= t40ÆiÅ;
end;
if ch='#' then
if ch<' ' then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putchnewbuf(nul)
else
if ch<>'$' then
if ch<' ' then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(ch);
end;
procedure puthl(t40: text40);
begin
putcontrol(highon,false);
put40(t40);
putcontrol(highoff,false);
end;
procedure putinv(t40: text40);
begin
putcontrol(invon,false);
put40(t40);
putcontrol(invoff,false);
end;
procedure putnumber(n,size: integer; hl:boolean);
var
a: alfa;
i,j,val: integer;
begin
if hl then
putcontrol(highon,false);
if n<0 then
begin
val:= - n;
putch('-');
end
else
val:= n;
i:= alfalength;
if size<0 then
begin
a:="000000000000";
size:=abs(size);
end
else
a:=" ";
repeat
aÆiÅ:=chr(ord('0')+ val mod 10);
val:= val div 10;
i:= i - 1;
until (i=0) or (val=0);
if alfalength-i < size then
i:= alfalength - size;
for j:=i+1 to alfalength do
putch(aÆjÅ);
if hl then
putcontrol(highoff,false);
end;
(*$r+*)
procedure putcursor(x,y: integer; newbuf: boolean);
var
v,c,pos: integer;
begin
with controlsÆcursorsetÅ do
begin
for pos:=1 to length do
begin
c:=ord(ctrlÆposÅ);
if c<192 then
putch(ctrlÆposÅ)
else
begin
c:=c-224;
if c>=0 then
v:=x
else
begin
c:=c+32;
v:=y;
end;
c:=c-16;
if c<0 then
begin
c:=c+16;
v:=v-1;
end;
c:=c-8;
if c>=0 then
v:=v+32
else
c:=c+8;
c:=c-4;
if c>=0 then
begin
if v<=31 then
v:=v+96
else
if v<=63 then
v:=v+32
else
v:=v-32;
end
else
c:=c+4;
c:=c-2;
if c>=0 then
putch(chr(v))
else
putnumber(v,-2,false);
end;
end;
end;
if newbuf then
putchnewbuf(nul);
end;
(*$r-*)
procedure setstatusline;
begin
cursorupdate:=true;
st_change:=false;
putcursor(1,statusline,false);
putcontrol(eraseeol,false);
if it then
begin
putinv(" INSERTING $");
putch(' ');
end;
if id then
begin
putinv(" INDENT $");
putch(' ');
end;
end;
procedure clearstatusline;
begin
st_change:=true;
putcursor(1,statusline,false);
putcontrol(eraseeol,false);
end;
function query(t40: text40): iso;
label 1;
var
que,oldque: iso;
begin
1:clearstatusline;
puthl(t40);
putchnewbuf(nul);
lastinbuf:=0;
que:=getnext;
oldque:=que;
while oldque>us do
oldque:=getnext;
if (oldque=bs) or (oldque=nul) then
goto 1;
query:=que;
end;
(*$r+*)
procedure putline(lineno,linepos: integer);
var
i,mark: integer;
begin
with filewindowÆlinenoÅ^ do
begin
if flagsÆ0,0Å=(1+lineno+storedline-firstwindow) then
begin
mark:=flagsÆ0,1Å;
if mark>(linelength+1) then
begin
mark:=linelength+1;
flagsÆ0,1Å:=mark;
end;
end
else
mark:=0;
putcursor(1,linepos,false);
for i:=1 to linelength do
begin
if mark=i then
putcontrol(invon,false);
if (lÆiÅ<' ') or (lÆiÅ>=del) then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
if mark=i then
putcontrol(invoff,false);
end;
putcontrol(eraseeol,false);
case attribute of
nul : begin
putcontrol(highon,false);
putch(lineconcat);
putcontrol(highoff,false);
end;
ff : begin
if mark=(linelength+1) then
putcontrol(invon,false);
putcontrol(highon,false);
putch(ffdisplay);
if mark=(linelength+1) then
putcontrol(invoff,false);
putcontrol(highoff,false);
end;
nl : if nlm then
begin
if mark=(linelength+1) then
putcontrol(invon,false);
putcontrol(highon,false);
putch(nldisplay);
if mark=(linelength+1) then
putcontrol(invoff,false);
putcontrol(highoff,false);
end
else
if mark=(linelength+1) then
begin
putcontrol(invon,false);
putch(" ");
putcontrol(invoff,false);
end;
end otherwise;
if linenumber then
begin
putcursor(lastinline-3,linepos,false);
putnumber((1+lineno+storedline-firstwindow) mod 10000,4,true);
end;
end;
end;
(*$r-*)
procedure update(first,last: integer);
begin
case updatestate of
noupdate:
begin
updatestate:= partialupdate;
firstupdate:= first;
lastupdate:= last;
end;
partialupdate:
begin
if firstupdate>first
then firstupdate:= first;
if lastupdate<last
then lastupdate:= last;
end;
allupdate: ;
end otherwise;
end;
procedure putdisplay;
begin
if firstupdate>lastupdate then
firstupdate:=lastupdate;
if (updatestate=allupdate)
and ((lastdisplay-firstdisplay)<(displaysize-1)) then
begin
firstdisplay:=lastdisplay-displaysize+1;
if firstdisplay<firstwindow then
firstdisplay:=firstwindow;
end;
if (firstupdate<firstdisplay) or (updatestate=allupdate)
then firstupdate:= firstdisplay;
if (lastupdate>lastdisplay) or (updatestate=allupdate)
then lastupdate:= lastdisplay;
if (scroll>(displaysize-5)) or (scroll_up>(displaysize-5)) or
((scroll>0) and (scroll_up>0)) then
begin
firstupdate:=firstdisplay;
lastupdate:=lastdisplay;
end;
if (scroll>0) and (firstupdate>firstdisplay) then
begin
clearstatusline;
for c:=1 to scroll-1 do
putch(nl);
putch(nl);
end;
scroll:=0;
if (scroll_up>0) and (lastupdate<lastdisplay) then
begin
if (controlsÆcursorupÅ.length>0) then
begin
putcursor(1,1,false);
for c:=1 to scroll_up do
putcontrol(cursorup,false);
clearstatusline;
end
else
begin
firstupdate:=firstdisplay;
lastupdate:=lastdisplay;
end;
end;
scroll_up:=0;
if it then
lastupdate:=insertline;
if (cury>=firstupdate) and (cury<=lastupdate) then
line_ex:=false;
putcursor(1,firstupdate-firstdisplay+1,false);
for i:=firstupdate to lastupdate-1 do
putline(i,i-firstdisplay+1);
while (filewindowÆlastupdateÅ^.attribute=nul)
and (lastupdate<lastdisplay) do
begin
putline(lastupdate,lastupdate-firstdisplay+1);
lastupdate:=lastupdate+1;
end;
putline(lastupdate,lastupdate-firstdisplay+1);
if linenumber and (not it) and (firstupdate<>lastupdate) then
for i:=lastupdate+1 to lastdisplay do
begin
putcursor(lastinline-3,i-firstdisplay+1,false);
putnumber((1+i+storedline-firstwindow) mod 10000,4,true);
end;
updatestate:= noupdate;
end;
procedure justifydisplay;
begin
firstdisplay:=cury-(displaysize div 2);
if firstdisplay<firstwindow then
firstdisplay:=firstwindow;
lastdisplay:=firstdisplay+displaysize-1;
if lastdisplay>lastwindow then
begin
lastdisplay:=lastwindow;
firstdisplay:=lastdisplay-displaysize+1;
end;
update(firstdisplay,lastdisplay);
end;
procedure attention(text: text40);
var
hold_bool:boolean;
ch: iso;
begin
clearstatusline;
if xr then
begin
putcursor(lastinline-11,statusline,false);
put40("Line =$");
putnumber(xr_line,4,false);
putcursor(1,statusline,false);
end;
putch(bel);
puthl(text);
if not break then
puthl(" ;Continue = <cr>, Stop = $")
else
begin
go_on:=false;
cont:=false;
puthl(" ;Return from command = <cr> or $");
end;
puthl(canceltxt);
putchnewbuf(bel);
hold_bool:=one_char;
one_char:=true;
lastinbuf:=nextinbuf;
ch:=getnext;
lastinbuf:=nextinbuf;
one_char:=hold_bool;
if ch=cancel then
begin
next_com:=false;
break:=true;
go_on:=false;
end
else
begin
next_com:=true;
if not break then
go_on:=true;
end;
st_change:=true;
end;
procedure setextension(ch1,ch2,ch3: char);
var
i: integer;
ch: iso;
first: boolean;
begin
i:= alfalength;
ch:= programnameÆiÅ;
first:= false;
while (ch=' ') or (ch=nul) do
begin
if ch=' ' then
begin
first:= true;
programnameÆiÅ:=chr(0);
end;
i:= i - 1;
ch:= programnameÆiÅ;
end;
if not first then
i:= i - 3;
programnameÆi+1Å:= ch1;
programnameÆi+2Å:= ch2;
programnameÆi+3Å:= ch3;
end;
procedure registerremove;
var
regindex,k: integer;
begin
for regindex:=1 to maxreg do
with regnamesÆregindexÅ do
if (reg<>nullalfa) and local then
k:= removeentry(fil);
end;
procedure initterminal;
var
i,k,buf,inkind,outkind: integer;
terminal: packed arrayÆ1..alfalengthÅ of iso;
pn: alfa;
tail: tailtype;
co: controltype;
ch : iso;
comch, c: integer;
value
terminal = ('t','e','r','m','i','n','a','l',nul,nul,nul,nul);
begin
exittest:=false;
k:= system(1,i,programname);
if k div 4096<>6 then
k:= system(0,i,programname);
ename:=programname;
pnameÆ1Å:='*';
pnameÆ2Å:='*';
pnameÆ3Å:='*';
for k:=4 to alfalength do
pnameÆkÅ:=programnameÆk-3Å;
for k:=1 to alfalength do
if pnameÆkÅ=' ' then
pnameÆkÅ:=chr(0);
setextension('p','a','r');
k:=lookupentry(programname,tail);
if (k<>0) or (tail.size<=1) then
begin
writeln(pname," No or empty parameterfile: ",programname);
exit;
end;
open(parmfile,programname);
reset(parmfile);
inkind:=getcurname(curinname.procname,curin);
curinname.nametable:= 0;
outkind:=abs(getcurname(curoutname.procname,curout));
curoutname.nametable:= 0;
parent(pn);
if not( ( (curoutname.procname=pn) and
(curinname.procname=terminal) and
(outkind=0) and (inkind=8) ) or
( (outkind=8) and (inkind=8) and
(curoutname.procname=curinname.procname) ) ) then
begin
writeln(pname," Terminal not online ");
exit;
end;
termmsg.operation:= 134*4096; (* Lookup term spec. *)
buf:= sendmessage(curinname,termmsg);
if buf=0 then
error("Lookup term spec. mess",1);
i:= waitanswer(buf,termmsg);
if i<>1 then
begin
termmsg.operation:= 2*4096; (* Lookup term spec. *)
buf:= sendmessage(curinname,termmsg);
if buf=0 then
error("Lookup term spec. mess",2);
i:= waitanswer(buf,termmsg);
if i<>1 then
begin
writeln(pname," Illegal terminal interface : ",curinname.procname);
exit;
end;
end;
if parmfile^<>'8' then
begin
writeln(pname," Incorrect parameterfile: ",programname);
exit;
end;
read(parmfile,i);
readln(parmfile);
if i<> versionnumber then
begin
close(parmfile);
write(pname," Wrong version of parameterfile: ",programname);
writeln(" Version must be: ",versionnumber);
exit;
end;
for co:=moveleft to cursorup do
with controlsÆcoÅ do
begin
length:=0;
while (not (parmfile^ in Ænl,';',' 'Å)) and (length<9) do
begin
read(parmfile,i);
if i>0 then
begin
length:=length+1;
ctrlÆlengthÅ:=chr(i);
end;
end;
readln(parmfile);
end;
readln(parmfile,i);
if i<32 then
cancel:=chr(i)
else
cancel:=esc;
readln(parmfile,lastinline);
readln(parmfile,statusline);
if lastinline>=linesize then
lastinline:=linesize-1;
lastinline:=lastinline-1;
displaysize:=statusline-1;
readln(parmfile,timeout,normaltimeout);
readln(parmfile,overlap);
readln(parmfile,i);
if i=0 then
typeahead:=false
else
typeahead:=true;
readln(parmfile,i);
if i=0 then
exittest:=false
else
exittest:=true;
readln(parmfile,convtabnr);
one_char:=false;
if convtabnr<0 then
begin
convtabnr:=-convtabnr;
one_char:=true;
end;
if not (convtabnr in Æ2,4,10..19Å) then
begin
close(parmfile);
writeln(pname," Illegal convert table number: ",convtabnr);
exit;
end;
if convtabnr = 2 then
conv_state := mode_csp;
if convtabnr = 4 then
conv_state := mode_csp_force;
if convtabnr > 9 then
begin
convtabnr := convtabnr - 10;
conv_state := mode_3600;
end;
with tabline^ do
begin
linelength:=1;
read(parmfile,ch);
while parmfile^<>nl do
begin
lÆlinelengthÅ:=ch;
read(parmfile,ch);
linelength:=linelength+1;
end;
lÆlinelengthÅ:=ch;
end;
readln(parmfile);
worddelimit:=Ænul..us,delÅ;
repeat
read(parmfile,ch);
worddelimit:=worddelimit+ÆchÅ;
until parmfile^=nl;
readln(parmfile);
readln(parmfile,i);
prefix:=chr(i);
readln(parmfile,i);
ci:=chr(i);
for comch:=-1 to 255 do
with commandsÆcomchÅ do
begin
linelength:=17;
l:='no ; Not defined';
lÆlinelengthÅ:=cr;
end;
repeat
while parmfile^=';' do
readln(parmfile);
read(parmfile,comch,ch);
if (ch<>':') or (comch>255) or (comch<(-1)) then
begin
close(parmfile);
writeln(pname," Illegal key definition: key",comch:4);
exit;
end;
with commandsÆcomchÅ do
begin
read(parmfile,ch);
linelength:=1;
while ch=' ' do
read(parmfile,ch);
while (linelength<lastinline-1)
and (parmfile^<>nl) do
begin
lÆlinelengthÅ:=ch;
read(parmfile,ch);
linelength:=linelength+1;
end;
lÆlinelengthÅ:=ch;
linelength:=linelength+1;
lÆlinelengthÅ:=cr;
end;
readln(parmfile);
until comch<0;
with commandsÆord(cancel)Å do
begin
linelength:=47;
l:=';This is the CANCEL key. It can not be defined';
lÆlinelengthÅ:=cr;
end;
with commandsÆord(cancel)+128Å do
begin
linelength:=47;
l:=';This is the CANCEL key. It can not be defined';
lÆlinelengthÅ:=cr;
end;
with commandsÆord(prefix)Å do
begin
linelength:=47;
l:=';This is the PREFIX key. It can not be defined';
lÆlinelengthÅ:=cr;
end;
with commandsÆord(prefix)+128Å do
begin
linelength:=23;
l:='cm&; <prefix> <prefix>';
lÆlinelengthÅ:=cr;
end;
readln(parmfile);
new(iline);
(* Input message inc. trail *)
with imsg do
begin
if one_char then
begin
operation:=(3*4096)+16*2;
last:=ord(iline);
end
else
begin
last:= ord(iline)+(abs(lastinline-curx) div charsinword)*halfsinword;
operation:=(3*4096)+16*(2-((lastinline-1) mod 3));
end;
first:= ord(iline);
x0 := 0;
x1 := 0;
x2 := 0;
x3 := 0;
x4 := 0;
end;
with smsg do
begin
operation:=(3*4096) + 64; (* Force input *)
first:=ord(iline);
last:= ord(iline)+(abs(lastinline-curx) div charsinword)*halfsinword;
x0:=0;
x1:=0;
x2:=0;
x3:=0;
x4:=0;
end;
lastinbuf:= 1;
nextinbuf:= 1;
new(oline);
omsg.operation:= 5*4096; (* Output message *)
nextobuf:= 1;
end;
(*$r+*)
procedure readpackedline(var f:isofile;l,startpos: integer; emchar:iso);
var
i: integer;
line: unpackedline;
begin
if filewindowÆlÅ=nil then
new(filewindowÆlÅ);
with filewindowÆlÅ^ do
begin
i:= startpos;
attribute:= nul;
if startpos>0 then
unpack(l,line,1);
readline(f,line,i,lastinline);
linelength:= i;
if f^ in Ænl,ffÅ then
begin
attribute:= f^;
skipchar(f);
end
else
if f^=em then
attribute:= emchar;
lineÆi+1Å:=nul;
lineÆi+2Å:=nul;
pack(line,1,l);
end;
end;
procedure writeline(lno: integer);
begin
storedline:= storedline + 1;
with filewindowÆlnoÅ^ do
begin
write(outfile,l:linelength);
if attribute<>nul then
write(outfile,attribute);
end;
end;
procedure windowaddempty(lines: integer);
var
i: integer;
begin
lastwindow:= lastwindow + lines;
for i:=lastwindow-lines+1 to lastwindow do
begin
if filewindowÆiÅ=nil then
new(filewindowÆiÅ);
with filewindowÆiÅ^ do
begin
linelength:=0;
attribute:=nl;
end;
end;
end;
procedure windowfill(fromline: integer; addlines,newattribute: boolean);
var
i: integer;
begin
if newattribute then
begin
if filewindowÆfromlineÅ=nil then
new(filewindowÆfromlineÅ);
with filewindowÆfromlineÅ^ do
begin
linelength:= 0;
readpackedline(infile,fromline,linelength,nl);
end;
end;
i:=fromline+1;
while not eof(infile) and (i<=windowsize) do
begin
readpackedline(infile,i,0,nl);
i:= i+1;
end;
lastwindow:= i-1;
if eof(infile) then
filewindowÆlastwindowÅ^.attribute:= nl;
if (lastwindow<lastdisplay) and addlines then
windowaddempty(lastdisplay-lastwindow);
end;
procedure windowextend(l,lastline: integer; newline:boolean);
var
savedline: lineptr;
i,j: integer;
begin
if newline then
begin
j:=1+lastline+storedline-firstwindow;
for i:=0 to 9 do
if flagsÆi,0Å>j then
flagsÆi,0Å:=flagsÆi,0Å+l;
end;
if l<firstwindow then
firstwindow:= firstwindow - l
else
for j:= firstwindow to firstwindow+l-1 do
writeline(j);
for j:=firstwindow to firstwindow+l-1 do
begin
savedline:= filewindowÆjÅ;
i:=j;
while i+l <= lastline do
begin
filewindowÆiÅ:= filewindowÆi+lÅ;
i:=i + l;
end;
filewindowÆiÅ:= savedline;
if filewindowÆiÅ=nil then
new(filewindowÆiÅ);
with filewindowÆiÅ^ do
begin
linelength:=0;
attribute:=nl;
end;
end;
if (updatestate=partialupdate) and
(firstupdate<=lastline) then
firstupdate:=firstupdate-l;
end;
procedure windowreduce(from,lines: integer);
var
savedline: lineptr;
i,j: integer;
begin
j:=1+from+storedline-firstwindow;
for i:=0 to 9 do
if flagsÆi,0Å>=(j+lines-1) then
flagsÆi,0Å:=flagsÆi,0Å-lines;
for j:=1 to lines do
begin
savedline:= filewindowÆfromÅ;
for i:=from to lastwindow-1 do
filewindowÆiÅ:= filewindowÆi+1Å;
filewindowÆlastwindowÅ:= savedline;
if eof(infile) then
lastwindow:= lastwindow - 1
else
readpackedline(infile,lastwindow,0,nl);
end;
end;
procedure writefile;
var
lastline,i,j: integer;
temp: unpackedline;
ptemp: linie;
begin
lastline:= lastwindow;
if eof(infile) then
while (filewindowÆlastlineÅ^.linelength=0) and
(filewindowÆlastlineÅ^.attribute=nl) and
(lastline>firstwindow) do
lastline:= lastline-1;
for i:=firstwindow to lastline do
writeline(i);
while not eof(infile) do
begin
i:=0;
storedline:=storedline+1;
readline(infile,temp,i,lastinline);
tempÆi+1Å:=nul;
tempÆi+2Å:=nul;
pack(temp,1,ptemp);
write(outfile,ptemp:i);
if infile^ in Æem,nl,ffÅ then
begin
write(outfile,infile^);
skipchar(infile);
end;
end;
close(outfile);
end;
(*$r-*)
procedure notext(fil:alfa);
begin
writeln(pname," Not a text file: ",fil);
terminate;
end;
procedure initfile(outtoin:boolean);
var
k,i: integer;
ch: iso;
tail: tailtype;
dummy,
inheadtail,outheadtail: headtailtype;
outputnew: boolean;
size: integer;
begin
nooutfile:=false;
noinfile:= false;
outputnew:=true;
if outtoin then
inname:=outname
else
begin
k:= system(1,i,inname);
if k mod 4096 = 4 then
begin
writeln(pname," Not a file: ",i:4);
terminate;
end;
noinfile:=(k=0);
if k div 4096 = 6 then
begin
k:=system(0,i,outname);
if k mod 4096 = 4 then
begin
writeln(pname," Not a file: ",i:4);
terminate;
end;
k:=system(2,i,inname);
if k mod 4096 = 4 then
begin
writeln(pname," Not a file: ",i:4);
terminate;
end;
noinfile:=(k=0);
end
else
begin
outname:=nullalfa;
nooutfile:=true;
end;
for i:=alfalength downto 1 do
begin
if innameÆiÅ =' ' then innameÆiÅ := chr(0);
if outnameÆiÅ=' ' then outnameÆiÅ:= chr(0);
end;
end;
if not nooutfile then
begin
outputnew:=(lookheadtail(outname,outheadtail)<>0);
if (outheadtail.tail.size<=0) and (not outputnew) then
notext(outname);
end;
if noinfile then
inname:=nullalfa
else
begin
k:=lookheadtail(inname,inheadtail);
if (inheadtail.tail.size<=0) and (k=0) then
begin
notext(inname);
end;
if k<>0 then
begin
if k=6 then
begin
writeln(pname," Not a file: ",inname);
terminate;
end;
if k<>3 then
notext(inname);
writeln(pname," Unknown file: ",inname);
terminate;
end;
end;
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(0);
size:=1;
end;
permkey:=0;
if (not nooutfile) and (not outputnew) then
begin
permkey:=outheadtail.key mod 8;
filebase:=outheadtail.base;
tail:=outheadtail.tail;
end
else
if not noinfile then
begin
permkey:=inheadtail.key mod 8;
filebase:=inheadtail.base;
tail:=inheadtail.tail;
if tail.size<=0 then
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(permkey);
if dummy.tail.resttailÆ8Å=0 then
size:=dummy.tail.size
else
size:=1;
end;
end;
if (not noinfile)
and ((inheadtail.tail.resttailÆ9Å div 4096)<>0) then
notext(inname);
if (not noinfile) and (tail.size<inheadtail.tail.size) then
tail.size:=inheadtail.tail.size;
for i:=6 to 10 do tail.resttailÆiÅ:=0;
tempname1:=nullalfa;
tempname2:=nullalfa;
if nooutfile and noinfile then
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(permkey);
end;
k:= createentry(tempname1,tail);
if k<>0 then
begin
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(0);
end;
k:= createentry(tempname1,tail);
end;
if nooutfile and noinfile then
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(permkey);
end;
i:= createentry(tempname2,tail);
if i<>0 then
begin
with tail do
begin
document:=nullalfa;
documentÆ3Å:=chr(0);
end;
i:= createentry(tempname2,tail);
end;
if (k<>0) or (i<>0) then
begin
if (k<>5) or (i<>5) then
writeln(pname," Not enough resources on any disc")
else
writeln(pname," Illegal process bases");
k:= removeentry(tempname1);
k:= removeentry(tempname2);
if outtoin then
begin
writeln("Backup OK ");
registerremove;
end;
terminate;
end;
if noinfile then
inname:=tempname2;
i:=createproc(inname);
if i<>0 then
begin
if i<>1 then
error("Create in",i);
writeln(pname," Area claims exceeded");
terminate;
end;
i:=reserveproc(inname);
if i=1 then
begin
writeln(pname," Input file protected");
terminate;
end;
if noinfile then
begin
open(infile,inname);
rewrite(infile);
close(infile);
end;
open(infile,inname);
reset(infile);
i:=createproc(tempname1);
if i<>0 then
begin
if i<>1 then
error("Create out",i);
writeln(pname," Area claims exceeded");
terminate;
end;
open(outfile,tempname1);
rewrite(outfile);
oddtempfile:= true;
end;
procedure closefiles(permkey: integer;
base: entrybase; var tail: headtailtype);
var
tempname,deletename : alfa;
k,i: integer;
begin
close(infile);
i:=releaseproc(inname);
if oddtempfile then
begin
tempname:= tempname1;
deletename:= tempname2;
end
else
begin
tempname:= tempname2;
deletename:= tempname1;
end;
if permkey > 0 then
begin
k:= permentry(tempname,permkey);
if k<>0 then
begin
putch(nl);
put40("Cannot make file $");
if permkey > 2 then
put40("permanent$")
else
put40("login$");
putchnewbuf(nl);
end
else
begin
if permkey > 2 then
k:= setentrybase(tempname,base);
if k<>0 then
begin
putch(nl);
put40("Entry protected,$");
put40(" file saved with lower scope$");
putchnewbuf(nl);
if setentrybase(tempname,basesÆuserbaseÅ)<>0 then
k:=permentry(tempname,2);
end;
end;
end;
k:=lookheadtail(tempname,tail);
k:= renameentry(tempname,outname);
if k=3 then
begin
k:= removeentry(outname);
if k<>0 then
begin
putch(nl);
put40("Cannot remove old file, $");
put40("new file is called: $");
putalfa(tempname,false);
putchnewbuf(nl);
outname:=tempname;
k:= 0;
end
else
k:= renameentry(tempname,outname);
end;
if k<>0 then
begin
putch(nl);
put40("Illegal file name, $");
put40("new file is called: $");
putalfa(tempname,false);
putchnewbuf(nl);
outname:=tempname;
k:= 0;
end;
k:= removeentry(deletename);
end;
(*$r+*)
procedure fill_line;
var
i: integer;
begin
with filewindowÆcuryÅ^ do
if curx > linelength then
begin
for i:=linelength+1 to curx-1 do
lÆiÅ:= ' ';
linelength:= curx - 1;
line_ex:=true;
end;
end;
function movedisplay(lines: integer): integer;
var
i,j,movelength: integer;
begin
movelength:= lines;
movedisplay:=0;
if lines > lastwindow - lastdisplay then
begin
if not eof(infile) then
begin
movedisplay:=lines;
windowextend(lines,lastwindow,false);
windowfill(lastwindow-lines,false,false);
if lastdisplay > lastwindow then
movelength:= lastwindow-lastdisplay
else
movelength:= 0;
end
else
movelength:= lastwindow-lastdisplay;
end;
firstdisplay:= firstdisplay + movelength;
lastdisplay:= lastdisplay + movelength;
update(firstdisplay,lastdisplay);
end;
procedure concatenate(x,y,lines: integer);
var
i,j,newlength: integer;
begin
with filewindowÆyÅ^ do
begin
if y+lines>lastwindow then
begin
linelength:= x - 1;
attribute:= nul;
windowfill(y,true,false);
update(y,lastdisplay);
end
else
begin
newlength:= x - 1 + filewindowÆy+linesÅ^.linelength;
if newlength <= lastinline then
begin
for i:=1 to filewindowÆy+linesÅ^.linelength do
lÆx-1+iÅ:= filewindowÆy+linesÅ^.lÆiÅ;
attribute:= filewindowÆy+linesÅ^.attribute;
linelength:= newlength;
windowreduce(y+1,lines);
update(y,lastdisplay);
end
else
begin
for i:=x to lastinline do
lÆiÅ:= filewindowÆy+linesÅ^.lÆi-x+1Å;
attribute:= nul;
linelength:= lastinline;
for i:=1 to newlength-lastinline do
filewindowÆy+1Å^.lÆiÅ:=
filewindowÆy+linesÅ^.
lÆi+lastinline-x+1Å;
filewindowÆy+1Å^.attribute:=filewindowÆy+linesÅ^.attribute;
filewindowÆy+1Å^.linelength:= newlength - lastinline;
windowreduce(y+2,lines-1);
if lines=1 then
update(y,y+1)
else
update(y,lastdisplay);
end;
end;
end;
if (lastwindow < lastdisplay) and eof(infile) then
windowaddempty(lastdisplay-lastwindow);
end;
procedure justifylines(from: integer);
var
i,j: integer;
begin
i:=from;
while filewindowÆiÅ^.attribute=nul do
begin
while (cury>=lastwindow) or (i>=lastwindow) do
begin
if cury>=windowsize then
i:=i-1;
linedown;
cury:=cury-1;
end;
with filewindowÆiÅ^ do
if linelength <=lastinline then
concatenate(linelength+1,i,1);
i:=i+1;
end;
end;
(*$r-*)
procedure delete(x: integer; var y:integer;lines,chars: integer);
var
i : integer;
begin
i:=cury;
cury:=y;
fill_line;
cury:=i;
update(y,y+lines);
if (y>=lastwindow) or (cury>=lastwindow) then
begin
if (cury>=windowsize) and (cury<>y) then
y:=y-1;
linedown;
cury:=cury-1;
end;
if chars>0 then
with filewindowÆyÅ^ do
begin
if (chars+x-1)<=linelength then
begin
for i:=0 to (linelength-chars-x) do
lÆx+iÅ:=lÆchars+x+iÅ;
linelength:=linelength-chars;
end
else
begin
chars:=chars-(linelength-x+1);
linelength:=x-1;
if attribute<>nul then
begin
chars:=chars-1;
attribute:=nul;
end;
if y<lastwindow then
begin
while chars>filewindowÆy+1Å^.linelength do
begin
chars:=chars-filewindowÆy+1Å^.linelength;
if filewindowÆy+1Å^.attribute<>nul then
chars:=chars-1;
windowreduce(y+1,1);
end;
with filewindowÆy+1Å^ do
begin
linelength:=linelength-chars;
for i:=1 to linelength do
lÆiÅ:=lÆchars+iÅ;
end;
end;
end;
end; (* chars *)
if lines>0 then
with filewindowÆyÅ^ do
begin
linelength:=x-1;
if attribute<>nul then
begin
attribute:=nul;
lines:=lines-1;
end;
while lines>0 do
begin
if filewindowÆy+1Å^.attribute<>nul then
lines:=lines-1;
windowreduce(y+1,1);
end;
end;
justifylines(y);
update(y,y);
end;
procedure insert(kind: insertkind; il: lineptr);
var
ol: linerec;
newlength,i,firsttoupdate: integer;
begin
fill_line;
ol:=filewindowÆcuryÅ^;
firsttoupdate:=cury;
case kind of
insertfile:
begin
readpackedline(regfile,cury,curx-1,nul);
while not eof(regfile) do
begin
windowextend(1,cury,true);
readpackedline(regfile,cury,0,nul);
firsttoupdate:=firstdisplay;
end;
end;
insertlinekind:
begin
if curx-1+il^.linelength<=lastinline then
with filewindowÆcuryÅ^ do
begin
for i:=1 to il^.linelength do
lÆcurx-1+iÅ:= il^.lÆiÅ;
attribute:= il^.attribute;
linelength:= curx-1+il^.linelength;
end
else
begin
with filewindowÆcuryÅ^ do
begin
for i:=1 to lastinline-curx+1 do
lÆcurx-1+iÅ:= il^.lÆiÅ;
attribute:= nul;
linelength:= lastinline;
end;
windowextend(1,cury,true);
with filewindowÆcuryÅ^ do
begin
for i:=1 to il^.linelength-(lastinline-curx+1) do
lÆiÅ:= il^.lÆlastinline-curx+1+iÅ;
attribute:= il^.attribute;
linelength:= il^.linelength-(lastinline-curx+1);
firsttoupdate:=firstdisplay;
end;
end;
end;
insertnl, insertff:
begin
with filewindowÆcuryÅ^ do
begin
linelength:= curx-1;
if kind=insertnl then
attribute:= nl
else
attribute:= ff;
end;
i:= 1;
while i<il^.linelength do
begin
windowextend(1,cury,true);
with filewindowÆcuryÅ^ do
begin
linelength:= 0;
attribute:= nl;
end;
i:= i + 1;
firsttoupdate:=firstdisplay;
end;
end;
end otherwise; (* case *)
if filewindowÆcuryÅ^.attribute<>nul then
begin
windowextend(1,cury,true);
filewindowÆcuryÅ^.linelength:= 0;
filewindowÆcuryÅ^.attribute:= nl;
firsttoupdate:= firstdisplay;
end;
newlength:= filewindowÆcuryÅ^.linelength+ol.linelength-curx+1;
if newlength<=lastinline then
with filewindowÆcuryÅ^ do
begin
for i:= 1 to ol.linelength-curx+1 do
lÆnewlength-i+1Å:=ol.lÆol.linelength-i+1Å;
linelength:= newlength;
attribute:= ol.attribute;
curx:= newlength - ol.linelength + curx;
end
else
begin
with filewindowÆcuryÅ^ do
begin
for i:=1 to lastinline-linelength do
lÆlinelength+iÅ:= ol.lÆcurx-1+iÅ;
linelength:= lastinline;
attribute:= nul;
end;
windowextend(1,cury,true);
firsttoupdate:= firstdisplay;
with filewindowÆcuryÅ^ do
begin
for i:=1 to newlength-lastinline do
lÆiÅ:= ol.lÆol.linelength-newlength+lastinline+iÅ;
linelength:= newlength-lastinline;
attribute:= ol.attribute;
end;
curx:= newlength - ol.linelength + curx;
if cury>firstwindow then
cury:= cury - 1
else
begin
cury:=firstwindow;
lineup;
end;
end;
justifylines(cury);
update(firsttoupdate,cury);
end;
function findreg(a: alfa): integer;
var
index: integer;
found: boolean;
begin
index:= maxreg;
found:= false;
while not found and (index>0) do
begin
found:= regnamesÆindexÅ.reg=a;
index:= index-1;
end;
if found then
findreg:= index+1
else
findreg:= 0;
end;
procedure registerinsert(cline:linie; var c:integer;
block:boolean; overwrite: boolean);
var
regname: alfa;
ch: iso;
i,regindex: integer;
del_count,length,startx,stopy: integer;
cont,old_cont,check_block: boolean;
begin
getalfa(cline,c,regname,"From register: $");
if go_on then
begin
if regname=nullalfa then
regname:= defaultreg;
regindex:= findreg(regname);
if regindex>0 then
begin
startx:=curx;
open(regfile,regnamesÆregindexÅ.fil);
reset(regfile);
if block then
begin
check_block:=true;
if cury=firstwindow then
begin
if storedline>0 then
check_block:=false;
end
else
if filewindowÆcury-1Å^.attribute=nul then
check_block:=false;
update(cury,cury);
clearstatusline;
puthl("Please wait#");
filewindowÆ0Å:=templine;
cont:=false;
if check_block and not overwrite then
begin
while not eof(regfile) do
begin
old_cont:=cont;
readpackedline(regfile,0,0,nl);
if filewindowÆ0Å^.attribute=nul then
cont:=true
else
cont:=false;
filewindowÆ0Å^.attribute:=nul;
if not old_cont then
curx:=startx;
if filewindowÆ0Å^.linelength>0 then
begin
fill_line;
insert(insertlinekind,filewindowÆ0Å);
end;
if (not cont) and (not eof(regfile)) then
begin
while filewindowÆcuryÅ^.attribute=nul do
linedown;
linedown;
end;
end;
update(cury,cury);
end
else
if check_block and overwrite then
begin
while not eof(regfile) do
begin
old_cont:=cont;
readpackedline(regfile,0,0,nl);
del_count:=filewindowÆ0Å^.linelength;
if filewindowÆ0Å^.attribute=nul then
cont:=true
else
cont:=false;
filewindowÆ0Å^.attribute:=nul;
if not old_cont then
curx:=startx;
while del_count>0 do
begin
if cury=lastwindow then
begin
linedown;
cury:=cury-1;
end;
length:=filewindowÆcuryÅ^.linelength-curx+1;
if length >= del_count then
begin
delete(curx,cury,0,del_count);
del_count:=0;
end
else
if (length<del_count) and (length>0) then
begin
if filewindowÆcuryÅ^.attribute=nul then
del_count:=del_count-length
else
del_count:=0;
delete(curx,cury,0,length);
end
else
del_count:=0;
end;
if filewindowÆ0Å^.linelength>0 then
begin
fill_line;
insert(insertlinekind,filewindowÆ0Å);
end;
if (not cont) and (not eof(regfile)) then
begin
while filewindowÆcuryÅ^.attribute=nul do
linedown;
linedown;
end;
end;
update(cury,cury);
end
else
attention("Illegal block start $");
end
else
begin
clearstatusline;
puthl("Please wait#");
insert(insertfile,templine);
end;
close(regfile);
end
else
attention(unknownregister);
end;
end;
procedure execute_register(cline:linie; var clinechar:integer);
var
regname: alfa;
i,regindex: integer;
begin
stopinsert(false);
if xr then
attention("Already executing register$")
else
begin
xr:=true;
xr_line:=0;
getalfa(cline,clinechar,regname,"Execute register: $");
if go_on then
begin
if regname=nullalfa then
regname:= defaultreg;
regindex:= findreg(regname);
if regindex>0 then
begin
open(exefile,regnamesÆregindexÅ.fil);
reset(exefile);
with templine^ do
while (not eof(exefile)) and (go_on) do
begin
filewindowÆ0Å:=templine;
readpackedline(exefile,0,0,nl);
xr_line:=xr_line+1;
if it then
begin
while it do
begin
i:=1;
while (i<=linelength) and it do
if lÆiÅ=it_del then
begin
it:=false;
linelength:=i-1;
attribute:=nul;
end
else
i:=i+1;
insert(insertlinekind,templine);
filewindowÆ0Å:=templine;
if (not eof(exefile)) and it then
begin
readpackedline(exefile,0,0,nl);
xr_line:=xr_line+1;
end
else
it:=false;
end;
end
else
begin
if attribute<>nl then
begin
break:=true;
attention("Command line too long $");
end
else
begin
lÆlinelength+1Å:=cr;
command(l,linelength);
end;
end;
end;
close(exefile);
end
else
attention(unknownregister);
end;
xr:=false;
end;
end;
procedure registerread(cline:linie; var c:integer);
var
regname,filname: alfa;
tail: tailtype;
regindex,k: integer;
ch: iso;
begin
clearstatusline;
getalfa(cline,c,regname,"To register: $");
if go_on then
getalfa(cline,c,filname,"From file: $");
if go_on then
begin
if filname=nullalfa then
begin
filname:= regname;
regname:= defaultreg;
end;
if regname=nullalfa then
regname:= defaultreg;
if regname=defaultreg then
begin
regindex:= findreg(regname);
if regindex<>0 then
with regnamesÆregindexÅ do
begin
if local then
regindex:= removeentry(fil);
reg:= nullalfa;
end;
end;
regindex:= findreg(regname);
if regindex=0 then
begin
k:= lookupentry(filname,tail);
if k=0 then
begin
if ((tail.resttailÆ9Å div 4096)=0) and
(tail.size>0) then
begin
regindex:= findreg(nullalfa);
if regindex<>0 then
with regnamesÆregindexÅ do
begin
reg:= regname;
fil:= filname;
local:= false;
end
else
attention(nomoreregisters);
end
else
attention("Not a text file $");
end
else
attention(filenonexisting);
end
else
attention(registerexists);
end;
end;
procedure registerwrite(cline:linie; var c:integer);
var
regname,filname: alfa;
k, regindex: integer;
ch: iso;
begin
clearstatusline;
getalfa(cline,c,regname,"From register: $");
if go_on then
getalfa(cline,c,filname,"To file: $");
if go_on then
begin
if filname=nullalfa then
begin
filname:= regname;
regname:= defaultreg;
end;
if regname=nullalfa then
regname:= defaultreg;
regindex:= findreg(regname);
if regindex<>0 then
begin
if regnamesÆregindexÅ.local then
begin
k:=renameentry(regnamesÆregindexÅ.fil,filname);
if k=0 then
with regnamesÆregindexÅ do
begin
fil:= filname;
local:= false;
end
else attention("Cannot create file $");
end
else attention("Register is already a file $");
end
else attention(unknownregister);
end;
end;
function findmark(var x,y: integer):boolean;
var
i: integer;
begin
if flagsÆ0,0Å>0 then
begin
x:=flagsÆ0,1Å;
y:=firstwindow+flagsÆ0,0Å-storedline-1;
if (y<firstwindow) or (y>lastwindow) then
findmark:=false
else
begin
findmark:=true;
if x>filewindowÆyÅ^.linelength+1 then
begin
x:=filewindowÆyÅ^.linelength+1;
flagsÆ0,1Å:=x;
end;
end;
end
else
findmark:=false;
end;
procedure toregister(deleteop:boolean; cline:linie;
var c:integer; block,blanck:boolean);
var
i,j,regindex: integer;
lines,chars,first: integer;
regname,filname: alfa;
tail: tailtype;
ch: iso;
first_line,check_block: boolean;
markx,marky: integer;
yline: lineptr;
begin
fill_line;
getalfa(cline,c,regname,"To register: $");
if go_on then
begin
if (regname=nullalfa) or (regname=defaultreg) then
begin
regname:= defaultreg;
regindex:= findreg(regname);
if regindex<>0 then
with regnamesÆregindexÅ do
begin
if local then
regindex:= removeentry(fil);
reg:= nullalfa;
end;
end;
regindex:= findreg(regname);
if regindex=0 then
begin
regindex:= findreg(nullalfa);
if regindex<>0 then
begin
with regnamesÆregindexÅ,tail do
begin
fil:= nullalfa;
size:= 1;
document:= nullalfa;
documentÆ3Å:=chr(1);
for i:=6 to 10 do
resttailÆiÅ:= 0;
i:= createentry(fil,tail);
end;
if i=0 then
begin
regnamesÆregindexÅ.reg:= regname;
regnamesÆregindexÅ.local:= true;
open(regfile,regnamesÆregindexÅ.fil);
rewrite(regfile);
if findmark(markx,marky) then
begin
if (marky>cury) then
begin
i:=cury;
cury:=marky;
marky:=i;
i:=curx;
curx:=markx;
markx:=i;
end;
if (marky=cury) and (curx<markx) then
begin
i:=curx;
curx:=markx;
markx:=i;
end;
clearstatusline;
puthl("Please wait#");
if block then
begin
if curx<markx then
begin
i:=curx;
curx:=markx;
markx:=i;
end;
check_block:=true;
if cury>firstwindow then
if filewindowÆcury-1Å^.attribute=nul then
check_block:=false;
if marky=firstwindow then
begin
if storedline>0 then
check_block:=false;
end
else
begin
if marky>firstwindow then
if filewindowÆmarky-1Å^.attribute=nul then
check_block:=false;
end;
if check_block then
begin
i:=marky;
yline:=filewindowÆcuryÅ;
first_line:=true;
repeat
if not first_line then
begin
while filewindowÆiÅ^.attribute=nul do
i:=i+1;
i:=i+1;
end
else
first_line:=false;
with filewindowÆiÅ^ do
for j:=markx to curx do
begin
if j>linelength then
write(regfile," ")
else
begin
write(regfile,lÆjÅ);
if blanck then
lÆjÅ:=" ";
end;
end;
write(regfile,nl);
if deleteop then
begin
if curx>filewindowÆiÅ^.linelength then
chars:=filewindowÆiÅ^.linelength+1-markx
else
chars:=curx+1-markx;
delete(markx,i,0,chars);
end;
if deleteop or blanck then
update(i,i);
until filewindowÆiÅ=yline;
if deleteop then
begin
curx:=markx;
cury:=marky;
update(cury,cury);
end;
end
else
attention("Illegal block marking $");
end
else
begin
if marky<>cury then
begin
with filewindowÆmarkyÅ^ do
begin
for i:=markx to linelength do
write(regfile,lÆiÅ);
if attribute<>nul then
write(regfile,attribute);
end;
for i:=1 to (cury-marky-1) do
with filewindowÆmarky+iÅ^ do
begin
write(regfile,l:linelength);
if attribute<>nul then
write(regfile,attribute);
end;
first:= 1;
end
else
first:=markx;
with filewindowÆcuryÅ^ do
for i:=first to curx-1 do
write(regfile,lÆiÅ);
if deleteop then
begin
i := cury;
delete(first,cury,0,curx-first);
i := i - cury;
marky := marky - i;
if marky < 1 then
marky := 1;
if cury<>marky then
concatenate(markx,marky,cury-marky);
curx:=markx;
cury:=marky;
update(cury,lastdisplay);
update(cury,cury);
end;
end;
if (cury<firstdisplay) or (cury>lastdisplay) then
begin
updatestate:=allupdate;
firstdisplay:=cury-(displaysize div 2);
if firstdisplay<firstwindow then
firstdisplay:=firstwindow;
lastdisplay:=firstdisplay+displaysize-1;
if lastdisplay>lastwindow then
begin
lastdisplay:=lastwindow;
firstdisplay:=lastdisplay-displaysize+1;
end;
end;
end
else
begin
if flagsÆ0,0Å>0 then
attention("Block too big $")
else
attention("No MARK set $");
end;
close(regfile);
end
else attention(cannotcreatereg);
end
else attention(nomoreregisters);
end
else attention(registerexists);
end;
end;
procedure registername;
var
i,k: integer;
ch: iso;
regname: alfa;
begin
putcursor(1,1,false);
putcontrol(eraseeos,true);
i:=maxreg;
puthl("REGISTERS IN USE: #");
putch(nl);
putch(nl);
while i>0 do
begin
if regnamesÆiÅ.reg<>nullalfa then
begin
regname:= regnamesÆiÅ.reg;
putalfa(regname,false);
regname:= regnamesÆiÅ.fil;
put40(" = $");
putalfa(regname,false);
if regnamesÆiÅ.local then
put40("; local$");
putchnewbuf(nl);
end;
i:= i-1;
end;
clearstatusline;
puthl("Press <cr> to continue #");
ch:=getnext;
while ch>us do
ch:=getnext;
if ch=cancel then
begin
break:=true;
go_on:=false;
end;
updatestate:= allupdate;
putcursor(1,1,false);
putcontrol(eraseeos,true);
end;
procedure registerdelete(cline:linie; var c:integer);
var
regindex: integer;
regname,filname: alfa;
ch: iso;
begin
getalfa(cline,c,regname,"Register: $");
if go_on then
begin
if regname=nullalfa then
regname:= defaultreg;
regindex:= findreg(regname);
if regindex<>0 then
with regnamesÆregindexÅ do
begin
if local then
regindex:= removeentry(fil);
reg:= nullalfa;
end
else attention(unknownregister);
end;
end;
procedure registerlist(cline:linie; var c:integer);
var
regname: alfa;
ch: iso;
lines,
mark,regindex: integer;
stop,lnum: boolean;
begin
lnum:=linenumber;
linenumber:=false;
mark:=flagsÆ0,0Å;
flagsÆ0,0Å:=0;
getalfa(cline,c,regname,"Register: $");
if go_on then
begin
if regname=nullalfa then
regname:= defaultreg;
regindex:= findreg(regname);
if regindex>0 then
begin
open(regfile,regnamesÆregindexÅ.fil);
putcursor(1,1,false);
reset(regfile);
putcontrol(eraseeos,true);
templine^:=filewindowÆcuryÅ^;
lines:=0;
stop:=false;
clearstatusline;
puthl("REGISTER: $");
putalfa(regname,false);
putcursor(1,1,false);
readpackedline(regfile,cury,0,nul);
while (not stop) and (not eof(regfile)) do
begin
lines:=lines+1;
putline(cury,lines);
if lines=displaysize-1 then
begin
clearstatusline;
puthl("REGISTER: $");
putalfa(regname,false);
puthl(" Next page = <cr>$");
puthl(" Stop = $");
puthl(canceltxt);
putchnewbuf(' ');
ch:=getnext;
while ch>us do
ch:=getnext;
lines:=0;
if ch = cancel then
begin
break:=true;
go_on:=false;
stop:=true;
end
else
begin
putcursor(1,1,false);
putcontrol(eraseeos,true);
clearstatusline;
puthl("REGISTER: $");
putalfa(regname,false);
putcursor(1,1,false);
end;
end;
readpackedline(regfile,cury,0,nul);
end;
if not stop then
begin
putline(cury,lines+1);
clearstatusline;
puthl("END REGISTER: $");
putalfa(regname,false);
if filewindowÆcuryÅ^.attribute=nul then
puthl(" Open end line ! $");
puthl(" Press <cr> to return #");
ch:=getnext;
while ch>us do
ch:=getnext;
end;
filewindowÆcuryÅ^:=templine^;
close(regfile);
updatestate:=allupdate;
putcursor(1,1,false);
putcontrol(eraseeos,true);
end
else
attention(unknownregister);
flagsÆ0,0Å:=mark;
linenumber:=lnum;
end;
end;
procedure controlinfo;
label 2;
var
i,length : integer;
scope,pn: alfa;
hold_bool: boolean;
ch: iso;
begin
putcursor(1,1,false);
putcontrol(eraseeos,false);
puthl("Screen Editor : $");
putalfa(ename,true);
puthl(release);
if exittest then
puthl(" Test active$");
putch(nl);
putinv("Process :$");
put40(" Parent=$");
parent(pn);
putalfa(pn,true);
put40(" Size=$");
putnumber(getsize,6,true);
put40(" Time=$");
putnumber(round(clock*100),6,true);
put40(" msek.$");
putch(nl);
putinv("Editor setup :$");
put40(" Work size=$");
putnumber(windowsize,4,true);
put40(" Last_col=$");
putnumber(lastinline,2,true);
put40(" Timeout: Rep=$");
putnumber(trunc(timeout),3,true);
put40(" Norm=$");
putnumber(trunc(normaltimeout),3,true);
putch(nl);
put40(" Temp_names=$");
putalfa(tempname1,true);putch(' ');putalfa(tempname2,true);
putch(nl);
put40(" $");
if inname<>nullalfa then
begin
put40(" Input=$");
putalfa(inname,true);
end;
if outname<>nullalfa then
begin
put40(" Output=$");
putalfa(outname,true);
end;
scope:="***";
if permkey=3 then
begin
if filebase=basesÆuserbaseÅ then
scope:="user"
else
if filebase=basesÆmaxbaseÅ then
scope:="project"
else
if (filebase.lowerbase=-8388607) and
(filebase.upperbase=8388605) then
scope:="system";
end
else
if permkey=2 then
scope:="login"
else
if permkey=0 then
scope:="temp";
put40(" Scope=$");
putalfa(scope,true);
putch(nl);
putinv("Terminal setup:$");
with localtermmsg do
begin
put40(" Terminal_name=$");
putalfa(curinname.procname,true);
if one_char then
puthl(" Single character input mode$")
else
begin
case conv_state of
mode_3600 : puthl(" RC3600 i/o mode$");
mode_csp : puthl(" CSP i/o mode (no input sense)$");
mode_csp_force : puthl(" CSP i/o mode (input sense active)$");
end otherwise;
end;
putch(nl);
put40(" Typeahead=$");
if typeahead then
puthl("active$")
else
puthl("passive$");
put40(" Chars_out=$");
putnumber(outch,4,true);
putch(nl);
put40(" Conv.$");
if conversion then putch('T') else putch('F');
put40(" Cont.$"); putnumber(continued,1,false);
put40(" Echo.$"); putnumber(echo,1,false);
put40(" Softpar.$");
if softparity then putch('T') else putch('F');
put40(" Type.$"); putnumber(ttype,1,false);
put40(" Att.$"); putnumber(attention,1,false);
putch(nl);
put40(" Prompt.$"); putnumber(ord(prompt),1,false);
put40(" Timer.$"); putnumber(timer,1,false);
put40(" FC.$"); putnumber(fc,1,false);
end;
putch(nl);
putinv("Editor state :$");
put40(" Display:$");
put40(" First=$");
putnumber(firstdisplay,4,true);
put40(" Last=$");
putnumber(lastdisplay,4,true);
put40(" Cursor: x=$");
putnumber(curx,2,true);
put40(" y=$");
putnumber(cury,2,true);
putch(nl);
put40(" Work :$");
put40(" First=$");
putnumber(firstwindow,4,true);
put40(" Last=$");
putnumber(lastwindow,4,true);
put40(" Stored=$");
putnumber(storedline,1,true);
put40(" Cur_line=$");
putnumber(1+cury+storedline-firstwindow,1,true);
putch(nl);
putinv("Flags (Mark=0):$");
for i:=0 to 9 do
begin
if flagsÆi,0Å>0 then
putnumber(flagsÆi,0Å,6,true)
else
puthl(" - $");
end;
putch(nl);
with findline^ do
if linelength>0 then
begin
putinv("Find line :$");
for i:=1 to linelength do
if lÆiÅ<' ' then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
putch(nl);
end;
with subfindline^ do
if linelength>0 then
begin
putinv("Sub. Find line:$");
for i:=1 to linelength do
if lÆiÅ<' ' then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
putch(nl);
end;
with subinsertline^ do
if linelength>0 then
begin
putinv("Sub. line :$");
for i:=1 to linelength do
if lÆiÅ<' ' then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
putch(nl);
end;
putinv("Line state :$");
put40(" Length=$");
length:= filewindowÆcuryÅ^.linelength;
putnumber(length,1,true);
put40(" Line_end_mark=$");
putnumber(ord(filewindowÆcuryÅ^.attribute),1,true);
put40(" Cur_char=$");
if length>=curx then
putnumber(ord(filewindowÆcuryÅ^.lÆcurxÅ),3,true)
else
puthl("Non$");
putch(nl);
putinv("Current line :$");
for i:=1 to length do
with filewindowÆcuryÅ^ do
begin
putnumber(ord(lÆiÅ),4,true);
if i mod 15 = 0 then
begin
putch(nl);
put40(" Char_pos. $");
putnumber(i+1,2,false);
put40(":$");
end;
end;
hold_bool:=one_char;
one_char:=true;
2: nextinbuf:=lastinbuf;
putcursor(1,statusline,false);
puthl("Press key to show key number$");
puthl(" or Cancel $");
putinv("($");
putinv(canceltxt);
putinv(")$");
puthl(" to return#");
i:=get_key_number;
while (i<>ord(cancel)) and (i>=0) do
begin
putcursor(48,statusline,false);
puthl(" Key number=$");
putnumber(i,3,true);
putchnewbuf(' ');
i:=get_key_number;
end;
if (i<>ord(cancel)) and (not break) then
goto 2;
break:=true;
go_on:=false;
one_char:=hold_bool;
putcursor(1,1,false);
putcontrol(eraseeos,false);
updatestate:= allupdate;
end;
procedure help(helpchar: iso);
var
ch,last_ch: iso;
stopud,nodisplay,hold_bool: boolean;
i: integer;
tail: tailtype;
begin
setextension('h','l', helpchar);
if lookupentry(programname,tail)=0 then
begin
open(parmfile,programname);
reset(parmfile);
stopud:= false;
while not eof(parmfile) and (not stopud) and (parmfile^<>'#') do
begin
clearstatusline;
last_ch:=' ';
read(parmfile,ch);
while not eof(parmfile) and not ((ch='?') and (last_ch<>'$')) do
begin
last_ch:=ch;
if ch='$' then
begin
read(parmfile,ch);
if ch='1' then
putcontrol(highon,false)
else
if ch='2' then
putcontrol(invon,false)
else
if ch='3' then
begin
putcursor(1,1,false);
putcontrol(eraseeos,false);
end
else
if ch='0' then
begin
putcontrol(invoff,false);
putcontrol(highoff,false);
end
else
putch(ch);
end
else
putch(ch);
read(parmfile,ch);
end;
putch(ch);
putcontrol(invoff,false);
putcontrol(highoff,true);
if (not eof(parmfile)) and (parmfile^<>nl) then
readln(parmfile);
hold_bool:=one_char;
one_char:=true;
ch:= getnext;
lastinbuf:=nextinbuf;
one_char:=hold_bool;
stopud:= (ch in Æ'e','E',enqÅ) or (ch=cancel);
if ch=cancel then
begin
break:=true;
go_on:=false;
end;
nodisplay:= ch in Æ'n','N',soÅ;
if not stopud then
begin
if not nodisplay then
begin
putcursor(1,1,false);
putcontrol(eraseeos,false);
end;
last_ch:=' ';
if not eof(parmfile) then
read(parmfile,ch);
while not ((ch='%') and (last_ch<>'$')) and not eof(parmfile) do
begin
last_ch:=ch;
if not nodisplay then
begin
if ch='$' then
begin
read(parmfile,ch);
if ch='1' then
putcontrol(highon,false)
else
if ch='2' then
putcontrol(invon,false)
else
if ch='3' then
begin
putcursor(1,1,false);
putcontrol(eraseeos,false);
end
else
if ch='0' then
begin
putcontrol(invoff,false);
putcontrol(highoff,false);
end
else
putch(ch);
end
else
putch(ch);
end;
read(parmfile,ch);
end;
putcontrol(invoff,false);
putcontrol(highoff,true);
if not eof(parmfile) then
readln(parmfile);
end;
end;
close(parmfile);
putcontrol(highoff,false);
putcontrol(invoff,false);
putcursor(1,1,false);
putcontrol(eraseeos,false);
updatestate:= allupdate;
end
else
begin
break:=true;
attention("Sorry. Help file not available $");
end;
end;
procedure find(fl: lineptr;stepone: boolean; var found: boolean);
var
i,fsp,length,distance,findlength: integer;
line: lineptr;
endwindow : boolean;
moves: integer;
ftable: arrayÆisoÅ of integer;
startclock:real;
ch: iso;
begin
flagsÆ6,0Å:=1+cury+storedline-firstwindow;
flagsÆ6,1Å:=curx;
findlength:= fl^.linelength;
if (curx>filewindowÆcuryÅ^.linelength) and (findlength>0) then
begin
curx:=1;
linedown;
end;
for ch:=nul to del do
ftableÆchÅ:= 0;
for i:=1 to findlength do
ftableÆfl^.lÆiÅÅ:= i;
if stepone or (findlength = 0) then
distance:= findlength
else
distance:= findlength - 1;
endwindow:= false;
startclock:=clock;
repeat
repeat
line:= filewindowÆcuryÅ;
if curx+distance-1>=line^.linelength then
begin
distance:= curx + distance;
length:= line^.linelength + ord(line^.attribute<>nul);
while (distance > length) and not endwindow do
begin
distance:= distance - length;
if cury>=lastdisplay then
begin
endwindow:= (eof(infile) and (lastdisplay=lastwindow));
if not endwindow then
cury:= cury - movedisplay(displaysize) + 1;
end
else
cury:= cury + 1;
line:= filewindowÆcuryÅ;
length:= line^.linelength + ord(line^.attribute<>nul);
end;
curx:= distance;
if distance > line^.linelength then
ch:= line^.attribute
else
ch:= line^.lÆcurxÅ;
distance:= findlength - ftableÆchÅ;
end
else
begin
curx:= curx + distance;
distance:= findlength - ftableÆline^.lÆcurxÅÅ;
end;
until (distance=0) or endwindow;
found:= not endwindow;
if found then
begin
fsp:= findlength - 1;
while (fsp>=1) and found do
begin
curx:= curx - 1;
if curx = 0 then
begin
cury:= cury - 1;
line:= filewindowÆcuryÅ;
if line^.attribute=nul then
begin
curx:= line^.linelength;
found:= (line^.lÆcurxÅ = fl^.lÆfspÅ);
end
else
begin
curx:= line^.linelength + 1;
found:= (line^.attribute = fl^.lÆfspÅ);
end;
end
else
found:= (line^.lÆcurxÅ = fl^.lÆfspÅ);
fsp:= fsp - 1;
end;
distance:= findlength - fsp;
end;
if (clock-startclock)>timeout then
begin
if typeahead then
begin
if sense then
found:=false;
startclock:=clock;
end
else
begin
attention("Command timeout $");
break:=true;
go_on:=false;
found:=false;
end;
end;
until endwindow or found or break;
if (updatestate=allupdate) and (cury>firstwindow+2) then
cury:= cury - movedisplay(cury-firstdisplay-overlap);
if endwindow then
curx:=filewindowÆcuryÅ^.linelength+1;
end;
procedure repeatcomm(var cline:linie;
length:integer;
var count:integer);
var startclock : real;
i : integer;
begin
i:=1;
next_com:=false;
startclock:=clock;
if (count>10) or (count<0) then
begin
clearstatusline;
puthl("Please wait#");
end;
while ((i<=count) or (count<=-1)) and go_on and (not next_com) do
begin
i:=i+1;
if count=-2 then
cont:=true
else
cont:=false;
command(cline,length);
if (count<=-1) and (clock-startclock>timeout) then
begin
if not typeahead then
attention("Command timeout $")
else
if sense then
count:=1;
startclock:=clock;
end;
if (count>1) and (clock-startclock>normaltimeout) then
begin
if not typeahead then
attention("Command timeout $")
else
if sense then
count:=1;
startclock:=clock;
end;
end;
if (count=-2) and not break then
go_on:=true;
end;
function getnumber(cline: linie;
var clinechar:integer; text:text40):integer;
var
c: integer;
templine:linerec;
begin
no_par:=false;
while clineÆclinecharÅ=' ' do
clinechar:=clinechar+1;
if clineÆclinecharÅ = ';' then
clineÆclinecharÅ:=cr;
c:=ord(clineÆclinecharÅ)-ord('0');
if (c<0) or (c>9) then
begin
if not ((c+ord('0')) in Æ13,10,44,46,59,38,37Å) then
begin
go_on:=false;
break:=true;
attention("Not a positive number $");
end;
if (c+ord('0'))=38 then
begin
clinechar:=clinechar+1;
clearstatusline;
putch(bel);
puthl(text);
c:=getline(templine.l);
c:=1;
getnumber:=getnumber(templine.l,c,text);
clearstatusline;
end
else
if (c+ord('0'))=37 then
begin
clinechar:=clinechar+1;
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
c:=0;
templine.l:=valuesÆcÅ.l;
c:=1;
getnumber:=getnumber(templine.l,c,text);
end
else
begin
no_par:=true;
getnumber:=0;
end;
end
else
begin
clinechar:=clinechar+1;
while ((clineÆclinecharÅ>='0') and
(clineÆclinecharÅ<='9')) do
begin
if c>99999 then
c:=0;
c:=c*10+ord(clineÆclinecharÅ)-ord('0');
clinechar:=clinechar+1;
end;
getnumber:=c;
end;
while clineÆclinecharÅ=' ' do
clinechar:=clinechar+1;
if clineÆclinecharÅ = ';' then
clineÆclinecharÅ:=cr;
end;
function getline(var comm:linie):integer;
var
x,c:integer;
begin
putchnewbuf(nul);
c:=1;
x:=curx;
curx:=1;
commÆcÅ:=getnext;
while (commÆcÅ<>cr) and (commÆcÅ<>cancel) and (c<linesize) do
begin
if commÆcÅ=prefix then
begin
commÆcÅ:=getnext;
if (commÆcÅ=cr) or (commÆcÅ=em) then
commÆcÅ:=nl;
if commÆcÅ<' ' then
begin
putcontrol(highon,false);
if commÆcÅ=nl then
putch(nldisplay)
else
if commÆcÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,true);
end;
c:=c+1;
end
else
if commÆcÅ in Æ bs,nul Å then
begin
c:=c-1;
if c=0 then
c:=1
else
begin
putcontrol(moveleft,false);
putch(' ');
putcontrol(moveleft,true);
end;
end
else
if commÆcÅ > us then
c:=c+1;
commÆcÅ:=getnext;
end;
if commÆcÅ=cancel then
begin
break:=true;
go_on:=false;
c:=1;
commÆ2Å:=cancel;
end;
if c>lastinline-20 then
updatestate:=allupdate;
if c=linesize then
begin
while commÆcÅ>us do
commÆcÅ:=getnext;
updatestate:=allupdate;
putdisplay;
break:=true;
attention("Line too long $");
c:=1;
end;
curx:=x;
commÆcÅ:=cr;
getline:=c;
end;
function lastinfile:boolean;
begin
lastinfile:= eof(infile)
and (cury=lastwindow)
and (curx>=filewindowÆcuryÅ^.linelength);
end;
procedure restorewindow;
var
i,oldy,oldx,oldlastdisplay: integer;
begin
oldy:=cury-firstdisplay;
oldx:=curx;
oldlastdisplay:=storedline+displaysize;
it:=true;
putcursor(lastinline-27,statusline,false);
i:=windowstart;
windowstart:=windowsize div 2;
puthl(" Reorganizing #");
st_change:=true;
it:=false;
jumptop;
if not sense then
begin
jumpline(oldlastdisplay,false);
windowstart:=i;
curx:=oldx;
cury:=firstdisplay+oldy;
end;
scroll_up:=0;
scroll:=0;
end;
procedure stopinsert(all:boolean);
var i: integer;
begin
if it then
begin
it:=false;
fill_line;
delete(filewindowÆinsertlineÅ^.linelength+1,insertline,1,0);
if all then
updatestate:=allupdate
else
update(insertline,lastdisplay);
st_change:=true;
end;
end;
procedure jumptop;
begin
if storedline>0 then
begin
if file_updated then
begin (* Write infile to outfile and use outfile as new infile *)
writefile;
close(infile);
oddtempfile:= not oddtempfile;
if oddtempfile then
begin
open(outfile,tempname1);
open(infile,tempname2);
end
else
begin
open(outfile,tempname2);
open(infile,tempname1);
end;
end;
reset(infile);
rewrite(outfile);
file_updated:=false;
firstwindow:= windowstart;
firstdisplay:= firstwindow;
lastdisplay:= firstdisplay + displaysize - 1;
windowfill(firstwindow,true,true);
storedline:= 0;
end
else
begin
firstdisplay:= firstwindow;
lastdisplay:= firstwindow + displaysize - 1;
end;
cury:= firstdisplay;
updatestate:= allupdate;
end;
(*$r+*)
procedure linedown;
var fdispline,xpos: integer;
begin (* Line Down *)
if cury=lastdisplay then
begin
if lastdisplay=lastwindow then
begin
if lastwindow<windowsize then
begin
windowfill(lastwindow+1,true,true);
lastdisplay:= lastdisplay + 1;
firstdisplay:= firstdisplay + 1;
end
else
begin
windowextend(1,lastwindow,false);
windowfill(lastwindow-1,true,false);
cury:= cury - 1;
end;
end
else
begin
lastdisplay:= lastdisplay + 1;
firstdisplay:= firstdisplay + 1;
end;
scroll:=scroll+1;
update(lastdisplay,lastdisplay);
end;
if it then
begin
windowextend(1,cury,true);
if firstdisplay<firstwindow+1 then
begin
stopinsert(false);
restorewindow;
templine^.linelength:=1;
insert(insertnl,templine);
cury:=cury-1;
filewindowÆcuryÅ^.linelength:=0;
insertline:=cury;
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
it:=true;
st_change:=true;
end;
updatestate:=noupdate;
update(cury-1,cury);
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
end
else
cury:=cury+1;
end;
procedure charright;
begin (* Char Right *)
if curx>lastinline then
begin
curx:=1;
linedown;
end
else
curx:=curx+1;
end;
(*$r-*)
procedure insertchar(ch:iso);
var i,xpos : integer;
begin
if (ch=nul) or (ord(ch)>127) then
attention("Illegal character $")
else
begin
fill_line;
level:=level+1;
if level>maxlevel*3 then
begin
break:=true;
go_on:=false;
attention("Line too long $");
end
else
begin
with filewindowÆcuryÅ^ do
begin
if (ch=nl) or (ch=em) then
begin
stopinsert(false);
templine^.linelength:=1;
insert(insertnl,templine);
lineup;
curx:=filewindowÆcuryÅ^.linelength+1;
end
else
if ch=ff then
begin
stopinsert(false);
templine^.linelength:=1;
insert(insertff,templine);
lineup;
curx:=filewindowÆcuryÅ^.linelength+1;
end
else
begin
for i:=linelength+1 downto curx+1 do
lÆiÅ:=lÆi-1Å;
lÆcurxÅ:=ch;
linelength:=linelength+1;
update(cury,cury);
if linelength>lastinline then
begin
linelength:=lastinline;
stopinsert(false);
if attribute=nul then
begin
xpos:=curx;
curx:=1;
linedown;
insertchar(lÆlastinline+1Å);
curx:=xpos;
lineup;
end
else
begin
attribute:=nul;
xpos:=curx;
windowextend(1,cury,true);
with filewindowÆcuryÅ^ do
begin
attribute:=nl;
linelength:=1;
lÆ1Å:=filewindowÆcury-1Å^.lÆlastinline+1Å;
end;
cury:=cury-1;
curx:=xpos;
update(firstdisplay,cury+1);
end;
end;
end;
end;
if cury<firstdisplay then
begin
if firstdisplay>firstwindow then
begin
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
updatestate:=allupdate;
end;
cury:=firstdisplay;
end;
end;
level:=level-1;
end;
end;
procedure delchar;
begin (* Delete char *)
if not (it and (filewindowÆcuryÅ^.linelength+1<=curx)) then
begin
delete(curx,cury,0,1);
update(cury,cury);
end;
end;
procedure jumpline(line:integer;just:boolean);
var i,newy: integer;
begin
if line<1 then
line:=1;
if line<1+storedline then
begin
putcursor(lastinline-27,statusline,false);
puthl(" Reorganizing #");
st_change:=true;
i:=windowstart;
windowstart:=windowsize div 2;
jumptop;
if not sense then
begin
windowstart:=i;
jumpline(line+displaysize-1,false);
cury:=firstdisplay;
if just then
justifydisplay;
update(firstdisplay,lastdisplay);
end;
st_change:=true;
end
else
begin
newy:=firstwindow+line-1-storedline;
if (newy<=lastdisplay) and (newy>=firstdisplay) then
cury:=newy
else
if newy<firstdisplay then
begin
firstdisplay:=newy;
lastdisplay:=firstdisplay+displaysize-1;
cury:=firstdisplay;
if just then
justifydisplay;
update(firstdisplay,lastdisplay);
end
else
begin
newy:=line-(1+lastdisplay+storedline-firstwindow);
while newy>0 do
begin
if newy>(lastwindow-firstwindow-1) then
i:=lastwindow-firstwindow-1
else
i:=newy;
newy:=newy-i;
i:=movedisplay(i);
end;
cury:=lastdisplay;
if just then
justifydisplay;
update(firstdisplay,lastdisplay);
end;
end;
end;
(*$r+*)
procedure charleft;
begin (* Char Left *)
if curx=1 then
begin
if (storedline>0) or (cury>firstwindow) then
begin
lineup;
curx:=filewindowÆcuryÅ^.linelength+1;
end;
end
else
curx:=curx-1;
end;
(*$r-*)
procedure lineup;
var i,newline:integer;
begin
stopinsert(false);
if cury>firstdisplay then
cury:=cury-1
else
if cury>firstwindow then
begin
cury:=cury-1;
firstdisplay:=cury;
lastdisplay:=firstdisplay+displaysize-1;
update(firstdisplay,firstdisplay);
scroll_up := scroll_up + 1;
end
else
begin
newline:=storedline;
if storedline>0 then
begin
putcursor(lastinline-27,statusline,false);
i:=windowstart;
windowstart:=windowsize div 2;
puthl(" Reorganizing #");
st_change:=true;
jumptop;
if not sense then
begin
jumpline(newline+displaysize-1,false);
windowstart:=i;
update(firstdisplay,lastdisplay);
cury:=firstdisplay;
end;
end;
end;
end;
procedure define_key(cline:linie;var clinechar:integer);
var
ch :iso;
pre :integer;
comm:linie;
c:integer;
sep:boolean;
begin
if clineÆclinecharÅ in Æ'&',crÅ then
begin
if clineÆclinecharÅ = '&' then
clinechar:=clinechar+1;
clearstatusline;
puthl("Define key $");
puthl("(number or press key):$");
putch(bel);
putchnewbuf(' ');
pre:=get_key_number;
end
else
pre:=getnumber(cline,clinechar,"Define key number: $");
sep:=false;
if not((pre>=0) and (pre<256) and
(pre<>ord(cancel)) and (pre<>(ord(cancel)+128))
and (pre<>ord(prefix)) and (pre<>(ord(prefix)+128))) then
begin
if not break then
begin
get_string(cline,clinechar,
"Key can not be defined. Press <cr> $",commandsÆ-1Å,sep);
if commandsÆ-1Å.linelength>0 then
attention("Key can not be defined $");
end;
end
else
begin
get_string(cline,clinechar,"Enter definition: $",commandsÆpreÅ,sep);
with commandsÆpreÅ do
begin
linelength:=linelength+1;
lÆlinelengthÅ:=cr;
end;
end;
end;
procedure delete_word;
var
ch:iso;
begin
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
while not ( (ch in worddelimit)
or ( curx>filewindowÆcuryÅ^.linelength )
) do
begin
delchar;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
while ( (ch in worddelimit)
and not ( curx>filewindowÆcuryÅ^.linelength )
) do
begin
delchar;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
end;
procedure exit_editor(commandch2:iso;cline:linie; var clinechar:integer);
label 1;
var
ypos,i : integer;
markx,marky : integer;
b_ins : boolean;
ch : iso;
name : linie;
tail : headtailtype;
scope : alfa;
new_name: alfa;
begin
stopinsert(false);
if commandch2='q' then
begin
clearstatusline;
if noinfile then
inname:=nullalfa;
if tc then
begin
putch(bel);
ch:= query("Quit editor, are you sure ? (no) #");
end
else
ch:='Y';
if (ch='y') or (ch='Y') or (ch=em) then
begin
clearstatusline;
close(infile);
close(outfile);
i:= removeentry(tempname1);
i:= removeentry(tempname2);
putch(nl);
putalfa(ename,false);
put40("end. $");
if tc then
begin
if backedup then
begin
put40("Changes after backup $");
put40("not saved in file $");
end
else
put40("Changes not saved in file $")
end
else
begin
if backedup then
begin
put40("No changes after backup $");
put40("of file $");
end
else
put40("No changes to file $");
end;
if nooutfile then
putalfa(inname,false)
else
putalfa(outname,false);
registerremove;
terminate; (* returns to FP *)
end;
end
else
begin
getalfa(cline,clinechar,new_name,"New result file name: $");
if break or (not go_on) then
goto 1;
if noinfile then
inname:=nullalfa;
if (new_name<>nullalfa) and (new_name<>outname) then
begin
backedup:=false;
outname:=new_name;
nooutfile:=false;
end;
if nooutfile then
begin
clearstatusline;
if inname=nullalfa then
begin
if oddtempfile then
inname:=tempname1
else
inname:=tempname2;
end;
putch(bel);
puthl("No resultfile. $");
puthl("Enter result file name ($");
putalfa(inname,false);
puthl("): #");
i:=getline(name);
if i<2 then
begin
if break or (not go_on) then
goto 1
else
outname:=inname;
end
else
begin
i:=1;
getalfa(name,i,outname,"$");
if break then
goto 1;
end;
nooutfile:=false;
end;
clearstatusline;
if commandch2='b' then
begin
if lastinfile and (filewindowÆcuryÅ^.linelength=0) then
begin
b_ins:=true;
insertchar(' ');
end
else
b_ins:=false;
i:=1+lastdisplay+storedline-firstwindow;
ypos:=1+cury+storedline-firstwindow;
puthl("Backing current text up in file $");
putalfa(outname,false);
backedup := true;
tc:=false;
file_updated:=false;
end
else
begin
clearstatusline;
puthl("Saving text in file $");
putalfa(outname,false);
end;
putchnewbuf(nul);
writefile;
if typeahead and (commandch2<>'b') then
begin
if sense then
begin
go_on:=false;
close(infile);
oddtempfile:= not oddtempfile;
if oddtempfile then
begin
open(outfile,tempname1);
open(infile,tempname2);
end
else
begin
open(outfile,tempname2);
open(infile,tempname1);
end;
reset(infile);
rewrite(outfile);
firstwindow:= windowstart;
firstdisplay:= firstwindow;
lastdisplay:= firstdisplay + displaysize - 1;
windowfill(firstwindow,true,true);
storedline:= 0;
cury:= firstdisplay;
updatestate:= allupdate;
end;
end;
if go_on then
case commandch2 of
'x': closefiles(permkey,filebase,tail);
't': closefiles(0,filebase,tail);
'l': closefiles(2,filebase,tail);
'u': closefiles(3,basesÆuserbaseÅ,tail);
'p': closefiles(3,basesÆmaxbaseÅ,tail);
'b': closefiles(permkey,filebase,tail);
end otherwise;
if (commandch2<>'b') and go_on then
begin
clearstatusline;
if backedup then
begin
putch(nl);
put40("Backup file is removed $");
end;
putch(nl);
putalfa(ename,false);
put40("end. $ ");
putnumber(storedline,5,false);
put40(" lines saved in $");
putalfa(outname,false);
scope:="***#";
with tail do
begin
if (key mod 8)=3 then
begin
if base=basesÆuserbaseÅ then
scope:="user#"
else
if base=basesÆmaxbaseÅ then
scope:="project#";
end
else
if (key mod 8)=2 then
scope:="login#"
else
if (key mod 8)=0 then
scope:="temp#";
end;
put40(" ($");
putalfa(scope,false);
putch('.');
putalfa(tail.tail.document,false);
put40(")#");
registerremove;
terminate; (* returns to FP *)
end
else
if go_on then
begin
initfile(true);
firstwindow:= windowstart;
firstdisplay:= firstwindow;
lastdisplay:= firstdisplay+displaysize-1;
windowfill(firstwindow,true,true);
cury:=1;
storedline:=0;
jumpline(i,false);
jumpline(ypos,false);
if b_ins then
delchar;
updatestate:=allupdate;
end
else
attention("File update aborted $");
end;
1:
end;
procedure get_string(cline:linie; var clinechar:integer;
text:text40; var string:linerec;
var sep:boolean);
var
seperator:iso;
c:integer;
begin (* get string *)
no_par:=false;
if clineÆclinecharÅ in Æcr,'&','%'Å then
begin
if clineÆclinecharÅ='%' then
begin
clinechar:=clinechar+1;
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
c:=0;
string:=valuesÆcÅ;
end
else
begin
clearstatusline;
if clineÆclinecharÅ = '&' then
clinechar:=clinechar+1;
putch(bel);
puthl(text);
with string do
linelength:=getline(l)-1;
if string.linelength<0 then
go_on:=false;
end;
sep:=false;
end
else
with string do
begin
linelength:=0;
if sep then
clinechar:=clinechar-1;
seperator:=clineÆclinecharÅ;
if seperator <> ';' then
begin
clinechar:=clinechar+1;
while (clinechar<linesize) and
(clineÆclinecharÅ<>seperator) and
(clineÆclinecharÅ<>cr) do
begin
linelength:=linelength+1;
lÆlinelengthÅ:=clineÆclinecharÅ;
clinechar:=clinechar+1;
end;
sep:=true;
if clineÆclinecharÅ<>cr then
clinechar:=clinechar+1;
end
else
begin
clineÆclinecharÅ:=cr;
sep:=false;
no_par:=true;
end;
end;
end;
procedure find_string(cline:linie; var clinechar:integer; next:boolean);
var
sep : boolean;
begin (* Find string *)
stopinsert(true);
if not next then
begin
sep:=false;
get_string(cline,clinechar,"Find: #",templine^,sep);
end
else
begin
templine^:=findline^;
end;
if (templine^.linelength>0) and (go_on or next) then
begin
findline^:=templine^;
clearstatusline;
puthl("Searching for: $");
with findline^ do
for i:=1 to linelength do
if lÆiÅ<' ' then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
putchnewbuf(nul);
find(findline,true,go_on);
if not (go_on or cont) and not break then
attention("String not found $");
if go_on then
begin
flagsÆ8,0Å:=1+cury+storedline-firstwindow;
flagsÆ8,1Å:=curx;
end;
if break then
go_on:=false;
end;
end;
procedure new_line;
var
xpos,ypos:integer;
pre: boolean;
begin
linedown;
if id then
begin
ypos:=cury;
repeat
with filewindowÆyposÅ^ do
begin
xpos:=1;
while (xpos<=linelength) and
(lÆxposÅ=' ') do
xpos:=xpos+1;
if (xpos>linelength) then
begin
pre:=false;
ypos:=ypos-1;
if ypos<=firstwindow then
begin
pre:=true;
xpos:=1;
end
else
while (filewindowÆypos-1Å^.attribute=nul) and
((ypos-1)>firstwindow) do
ypos:=ypos-1;
if ((ypos-1)=firstwindow) and
(filewindowÆfirstwindowÅ^.attribute=nul) then
ypos:=firstwindow;
end
else
pre:=true;
end;
until pre;
curx:=xpos;
end
else
curx:=1;
end;
procedure next_page;
var
i,j:integer;
begin
stopinsert(true);
if (eof(infile) and (lastdisplay=lastwindow)) then
cury:=lastdisplay
else
begin
i:=1+lastdisplay+displaysize-overlap
+storedline-firstwindow;
j:=1+cury+storedline-firstwindow;
jumpline(i,false);
if j>=(i-displaysize+1) then
cury:=firstwindow+j-1-storedline
else
cury:=firstdisplay;
end;
end;
procedure prev_page;
var
i,j:integer;
begin
stopinsert(true);
if (firstdisplay=firstwindow) and (storedline=0) then
cury:=firstdisplay
else
begin
i:=1+firstdisplay-displaysize+overlap
+storedline-firstwindow;
j:=1+cury+storedline-firstwindow;
jumpline(i,false);
if j<=(i+displaysize-1) then
cury:=firstwindow+j-1-storedline
else
cury:=lastdisplay;
end;
end;
procedure show_key(cline:linie; var clinechar:integer);
var
ch:iso;
pre:integer;
comm:linie;
i,c:integer;
begin
if clineÆclinecharÅ in Æ'&',crÅ then
begin
if clineÆclinecharÅ = '&' then
clinechar := clinechar+1;
clearstatusline;
puthl("Show key $");
puthl("(number or press key):$");
putch(bel);
putchnewbuf(' ');
pre:=get_key_number;
end
else
pre:=getnumber(cline,clinechar,"Show key number: $");
if (pre>=0) and (pre<256) then
begin
clearstatusline;
puthl("Key $");
putnumber(pre,1,true);
puthl(" defined as: $");
comm:=commandsÆpreÅ.l;
c:=commandsÆpreÅ.linelength;
for i:=1 to c-1 do
if commÆiÅ<' ' then
begin
putcontrol(highon,false);
if commÆiÅ=nl then
putch(nldisplay)
else
if commÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(commÆiÅ);
putch(' ');
putchnewbuf(bel);
ch:=getnext;
while (ch<>cr) and (ch<>cancel) do
ch:=getnext;
if i>(lastinline-21) then
updatestate:=allupdate;
end
else
if not break then
attention("Illegal key number $");
if ch=cancel then
begin
go_on:=false;
break:=true;
end;
end;
procedure sub_insert(il: lineptr);
var c:integer;
begin
templine^.linelength:=0;
for c:=1 to il^.linelength do
begin
if il^.lÆcÅ in Ænl,ffÅ then
begin
templine^.attribute:=il^.lÆcÅ;
insert(insertlinekind,templine);
templine^.linelength:=0;
end
else
begin
templine^.linelength:=templine^.linelength+1;
templine^.lÆtempline^.linelengthÅ:=il^.lÆcÅ;
end;
end;
templine^.attribute:=il^.attribute;
if templine^.linelength > 0 then
insert(insertlinekind,templine);
end;
procedure sub_string(cline:linie; var clinechar:integer; next:boolean);
var
i,j:integer;
sep,quest,hold_bool:boolean;
ch:iso;
fholdline,sholdline:linerec;
begin
stopinsert(true);
quest:=false;
if next then
begin
if clineÆclinecharÅ='?' then
begin
quest:=true;
clinechar:=clinechar+1;
end
else
begin
getalfa(cline,clinechar,alf,"Confirm substitute ? (no): #");
if alfÆ1Å in Æ'?','Y','y',emÅ then
quest:=true
else
quest:=false;
if (subfindline^.attribute='q') and (alf=nullalfa) then
quest:=true
end;
end
else
begin
sep:=false;
get_string(cline,clinechar,"Substitute: #",fholdline,sep);
if go_on then
get_string(cline,clinechar,"With: #",sholdline,sep);
if go_on and (clineÆclinecharÅ in Æ'?','%','&'Å) then
begin
if clineÆclinecharÅ='?' then
begin
clinechar:=clinechar+1;
quest:=true;
end
else
begin
getalfa(cline,clinechar,alf,"Confirm substitute ? (no): #");
if alfÆ1Å in Æ'?','Y','y',emÅ then
quest:=true;
end;
end;
if go_on then
begin
subfindline^:=fholdline;
subfindline^.attribute:=nul;
subinsertline^:=sholdline;
subinsertline^.attribute:=nul;
end;
end;
if go_on then
begin
with subfindline^ do
if linelength>0 then
begin
clearstatusline;
puthl("Searching for: $");
for i:=1 to linelength do
if lÆiÅ<' ' then
begin
putcontrol(highon,false);
if lÆiÅ=nl then
putch(nldisplay)
else
if lÆiÅ=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(lÆiÅ);
putchnewbuf(nul);
end;
i:=firstdisplay;
j:=lastdisplay;
if subfindline^.linelength=0 then
fill_line;
find(subfindline,false,go_on);
if not (go_on or cont) then
begin
if break then
go_on:=false
else
attention("String not found $");
end
else
if go_on then
begin
flagsÆ7,0Å:=1+cury+storedline-firstwindow;
flagsÆ7,1Å:=curx;
if quest then
begin
if (updatestate<>noupdate) or
(cury<i) or (cury>j) then
putdisplay;
subfindline^.attribute:='q';
clearstatusline;
puthl("Substitute ? $");
puthl("Yes = <cr> or Ctrl-Y, $");
puthl("No = Ctrl-N, $");
puthl("End = Ctrl-E$");
putcursor(curx,cury-firstdisplay+1,true);
hold_bool:=one_char;
one_char:=true;
ch:=getnext;
lastinbuf:=nextinbuf;
one_char:=hold_bool;
if ch>us then
update(cury,cury);
if ch in Æcr,em,'y','Y'Å then
begin
if subinsertline^.linelength>0 then
sub_insert(subinsertline);
delete(curx,cury,0,subfindline^.linelength);
if cury<firstdisplay then
begin
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
update(firstdisplay,lastdisplay);
end;
update(cury,cury);
putdisplay;
putcursor(curx,cury-firstdisplay+1,true);
end
else
if (ch=cancel) or (ch in Æenq,'e','E'Å) then
begin
if ch=cancel then
break:=true;
go_on:=false;
end
else
begin
curx:=curx+1;
if curx>filewindowÆcuryÅ^.linelength then
begin
cury:=cury+1;
curx:=1;
end;
end;
end
else
begin
if subinsertline^.linelength>0 then
sub_insert(subinsertline);
delete(curx,cury,0,subfindline^.linelength);
if cury<firstdisplay then
begin
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
update(firstdisplay,lastdisplay);
end;
end;
end;
end;
end;
procedure tab_right;
var
xpos:integer;
begin
xpos:=curx+1;
while (tabline^.lÆxposÅ<>'!') and
(xpos<=tabline^.linelength) do
xpos:=xpos+1;
if xpos>tabline^.linelength then
begin
xpos:=1;
while (tabline^.lÆxposÅ<>'!') and
(xpos<=tabline^.linelength) do
xpos:=xpos+1;
if xpos<=tabline^.linelength then
begin
curx:=xpos;
linedown;
end;
end
else
curx:=xpos;
end;
procedure tab_left;
var
xpos:integer;
pre:boolean;
begin
xpos:=curx-1;
pre:=false;
while (xpos>=1) and not pre do
if (tabline^.lÆxposÅ='!') then
pre:=true
else
xpos:=xpos-1;
if xpos=0 then
begin
xpos:=tabline^.linelength;
pre:=false;
while (xpos>=1) and not pre do
if (tabline^.lÆxposÅ='!') then
pre:=true
else
xpos:=xpos-1;
if xpos>0 then
begin
curx:=xpos;
lineup;
end;
end
else
curx:=xpos;
end;
procedure word_left;
var
ch:iso;
begin
charleft;
while curx>filewindowÆcuryÅ^.linelength do
charleft;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
while (ch in worddelimit) and
not((curx=1) and (cury=firstwindow) and
(storedline=0)) do
begin
charleft;
while curx>filewindowÆcuryÅ^.linelength do
charleft;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
while not((ch in worddelimit) or (curx=1)) do
begin
charleft;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
if ch in worddelimit then
charright;
end;
procedure word_right;
var
ch:iso;
begin
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
while not((ch in worddelimit)
or (curx>filewindowÆcuryÅ^.linelength)
or lastinfile) do
begin
charright;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
while (curx>filewindowÆcuryÅ^.linelength)
and not (lastinfile or it) do
begin
curx:=1;
linedown;
end;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
while (ch in worddelimit)
and not (curx>filewindowÆcuryÅ^.linelength)
and not (lastinfile) do
begin
charright;
while (curx>filewindowÆcuryÅ^.linelength)
and not (lastinfile or it) do
begin
curx:=1;
linedown;
end;
ch:=filewindowÆcuryÅ^.lÆcurxÅ;
end;
end;
procedure find_newline;
begin
stopinsert(true);
flagsÆ6,0Å:=1+cury+storedline-firstwindow;
flagsÆ6,1Å:=curx;
if not (eof(infile) and (cury=lastwindow)) then
begin
if curx>filewindowÆcuryÅ^.linelength then
linedown;
while filewindowÆcuryÅ^.attribute<>nl do
linedown;
end;
curx:=filewindowÆcuryÅ^.linelength+1;
end;
procedure find_page;
var startclock:real;
begin
startclock:=clock;
stopinsert(true);
flagsÆ6,0Å:=1+cury+storedline-firstwindow;
flagsÆ6,1Å:=curx;
clearstatusline;
puthl("Searching for page mark #");
if (curx>filewindowÆcuryÅ^.linelength) and
not (eof(infile) and (cury=lastwindow)) then
linedown;
while (filewindowÆcuryÅ^.attribute<>ff) and go_on and
not (eof(infile) and (cury=lastwindow)) do
begin
linedown;
if (clock-startclock)>timeout then
begin
if typeahead then
begin
if sense then;
startclock:=clock;
end
else
attention("Command timeout $");
end;
end;
curx:=filewindowÆcuryÅ^.linelength+1;
if (filewindowÆcuryÅ^.attribute<>ff) and
(eof(infile) and (cury=lastwindow)) then
begin
go_on:=false;
if not cont then
attention("Page mark not found $");
end;
end;
procedure find_char(cline:linie; var clinechar:integer);
var ch:iso;
startclock:real;
begin
startclock:=clock;
stopinsert(true);
flagsÆ6,0Å:=1+cury+storedline-firstwindow;
flagsÆ6,1Å:=curx;
ch:=chr(getnumber(cline,clinechar,"Character value: $"));
if go_on then
begin
if (ch=nul) or (ord(ch)>127) then
attention("Illegal character $")
else
begin
if (ch=nl) or (ch=em) then
find_newline
else
if ch=ff then
find_page
else
begin
clearstatusline;
puthl("Searching for character: $");
putnumber(ord(ch),3,true);
putch(' ');
putch('(');
if (ch<' ') or (ch>=del) then
begin
putcontrol(highon,false);
if ch=nl then
putch(nldisplay)
else
if ch=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(ch);
putchnewbuf(')');
if not lastinfile then
begin
if (curx+1)<=filewindowÆcuryÅ^.linelength then
curx:=curx+1
else
begin
curx:=1;
linedown;
end;
end;
while (ch<>filewindowÆcuryÅ^.lÆcurxÅ) and go_on and
not lastinfile do
begin
if (curx+1)<=filewindowÆcuryÅ^.linelength then
curx:=curx+1
else
begin
curx:=1;
linedown;
end;
if ((clock-startclock)>timeout) then
begin
if typeahead then
begin
if sense then;
startclock:=clock;
end
else
attention("Command timeout $");
end;
end;
if (ch<>filewindowÆcuryÅ^.lÆcurxÅ) and lastinfile then
begin
go_on:=false;
if not cont then
attention("Character not found $");
curx:=filewindowÆcuryÅ^.linelength+1;
end;
end;
end;
end;
end;
procedure ic(cline:linie; var clinechar:integer);
var ch:integer;
begin
ch:=getnumber(cline,clinechar,"Character value: $");
if go_on then
insertchar(chr(ch));
end;
procedure cut_blanks(cline:linie; var clinechar:integer);
var oldx,first_line,count: integer;
begin
getalfa(cline,clinechar,alf,"Cut blanks After/Before/Inline (I): $");
if not (lastinfile and (filewindowÆcuryÅ^.linelength=0)) and go_on then
begin
if ((alfÆ1Å='i') or (alf=nullalfa)) then
begin
charright;
while (filewindowÆcuryÅ^.lÆcurxÅ=" ") and
(curx<=filewindowÆcuryÅ^.linelength) do
delete(curx,cury,0,1);
charleft;
end
else
begin
if (alfÆ1Å='a') then
begin
oldx:=curx;
first_line:=cury;
while filewindowÆcuryÅ^.attribute=nul do
linedown;
curx:=filewindowÆcuryÅ^.linelength;
if curx>0 then
begin
count:=0;
while (filewindowÆcuryÅ^.lÆcurxÅ=" ") and
not ((curx<=oldx) and (cury=first_line)) do
begin
count:=count+1;
charleft;
while filewindowÆcuryÅ^.linelength<curx do
charleft;
end;
if count>0 then
begin
charright;
delete(curx,cury,0,count);
charleft;
end;
if (curx=oldx) and (cury=first_line) and
(filewindowÆcuryÅ^.lÆcurxÅ=" ") then
delete(curx,cury,0,1);
end;
curx:=oldx;
linedown;
end
else
begin
if cury>firstwindow then
while (cury>firstwindow) and (filewindowÆcury-1Å^.attribute=nul) do
cury:=cury-1;
count:=1;
with filewindowÆcuryÅ^ do
while (lÆcountÅ=' ') and (count<curx) and (count<=linelength) do
count:=count+1;
if count>1 then
delete(1,cury,0,count-1);
while filewindowÆcuryÅ^.attribute=nul do
linedown;
linedown;
end;
end;
end
else
if go_on then
begin
go_on:=false;
if not (cont or break) then
attention("Text end $");
end;
end;
procedure command_mode(cline:linie;var clinechar:integer);
var
comm:linerec;
sep:boolean;
begin (* Command Mode *)
sep:=false;
get_string(cline,clinechar,"COMMAND: $",comm,sep);
if go_on and (comm.linelength>0) then
command(comm.l,comm.linelength);
end;
function emptyline: boolean;
var
i : integer;
empty : boolean;
begin
empty:=true;
if filewindowÆcuryÅ^.linelength > 0 then
begin
i:=1;
repeat
if filewindowÆcuryÅ^.lÆiÅ <> " " then
empty:=false;
i:=i+1;
until (not empty) or (i>filewindowÆcuryÅ^.linelength);
end;
emptyline := empty;
end;
procedure clear_flag(cline:linie; var clinechar:integer);
var c,j:integer;
begin
c:=getnumber(cline,clinechar,"Clear flag number: $");
if go_on then
begin
if (c<0) or (c>9) then
attention("Illegal flag $")
else
begin
j:=flagsÆ0,0Å+firstwindow-storedline-1;
flagsÆc,0Å:=0;
flagsÆc,1Å:=0;
if c=0 then
begin
if (j>=firstdisplay) and (j<=lastdisplay) then
begin
if updatestate=noupdate then
begin
update(j,j);
putdisplay;
end
else
update(j,j);
end;
end;
end;
end;
end;
procedure find_mark;
begin
stopinsert(true);
flagsÆ6,0Å:=1+cury+storedline-firstwindow;
flagsÆ6,1Å:=curx;
if (not findmark(curx,cury)) and (flagsÆ0,0Å>0) then
begin
clearstatusline;
puthl("Moving to MARK $");
jumpline(flagsÆ0,0Å,true);
end;
if not findmark(curx,cury) then
attention("No MARK set $")
else
if (cury<firstdisplay) or (cury>lastdisplay) then
begin
justifydisplay;
updatestate:=allupdate;
end;
end;
procedure get_value(cline:linie; var clinechar:integer);
var c:integer;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
if not st_change then
clearstatusline;
putch(bel);
valuesÆcÅ.linelength:=getline(templine^.l)-1;
valuesÆcÅ.l:=templine^.l;
end;
end;
procedure get_time(cline:linie; var clinechar:integer);
var c,i:integer;
alf:alfa;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
valuesÆcÅ.linelength:=5;
time(alf);
with valuesÆcÅ do
begin
for i:=1 to 5 do
lÆiÅ:=alfÆiÅ;
lÆ6Å:=cr;
end;
end;
end;
procedure get_date(cline:linie; var clinechar:integer);
var c,i:integer;
alf:alfa;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
valuesÆcÅ.linelength:=8;
date(alf);
with valuesÆcÅ do
begin
for i:=1 to 8 do
lÆiÅ:=alfÆiÅ;
lÆ9Å:=cr;
end;
end;
end;
procedure put_variable(cline:linie; var clinechar:integer);
var c,i:integer;
alf:alfa;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
with valuesÆcÅ do
begin
for i:=curx to filewindowÆcuryÅ^.linelength do
lÆi-curx+1Å:=filewindowÆcuryÅ^.lÆiÅ;
if curx>filewindowÆcuryÅ^.linelength then
begin
lÆ1Å:=cr;
linelength:=0;
end
else
begin
lÆfilewindowÆcuryÅ^.linelength-curx+2Å:=cr;
linelength:=filewindowÆcuryÅ^.linelength-curx+1;
end;
end;
end;
end;
procedure get_parameter(cline:linie; var clinechar:integer);
var j,c,i,p,result:integer;
negativ:boolean;
alf:alfa;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
p:=getnumber(cline,clinechar,"Parameter number: $");
if no_par then
attention("Illegal parameter number$")
else
begin
result:=system(p,i,alf) mod 4096;
if result=0 then
alf:=nullalfa
else
if result=4 then
begin
alf:=' ';
j:=alfalength;
if i<0 then
begin
i:= -i;
negativ:=true;
end
else
negativ:=false;
repeat
alfÆjÅ:=chr(ord('0')+ i mod 10);
i:= i div 10;
j:= j - 1;
until (j=0) or (i=0);
if j=0 then
alf:='************';
if negativ then
alfÆjÅ:='-';
end;
with valuesÆcÅ do
begin
linelength:=12;
for i:=1 to 12 do
lÆiÅ:=alfÆiÅ;
lÆ13Å:=cr;
if alf=nullalfa then
begin
linelength:=0;
lÆ1Å:=cr;
end;
end;
end;
end;
end;
procedure inc_variable(cline:linie; var clinechar:integer;inc:boolean);
var j,c,i,p,result:integer;
alf:alfa;
begin
c:=getnumber(cline,clinechar,"Variable number: $");
if c>9 then
attention("Illegal variable number$")
else
begin
p:=1;
i:=getnumber(valuesÆcÅ.l,p,"Value: $");
if go_on then
begin
if inc then
i:=i+1
else
i:=i-1;
if (i<0) or (i=maxint) then
i:=0;
alf:=' ';
j:=alfalength;
repeat
alfÆjÅ:=chr(ord('0')+ i mod 10);
i:= i div 10;
j:= j - 1;
until (j=0) or (i=0);
if j=0 then
alf:='************';
with valuesÆcÅ do
begin
for i:=1 to 12 do
lÆiÅ:=alfÆiÅ;
lÆ13Å:=cr;
linelength:=12;
end;
end;
end;
end;
procedure insert_text(cline:linie; var clinechar:integer);
begin
if xr then
begin
tc:=true;
file_updated:=true;
it:=true;
it_del:=clineÆclinecharÅ;
clinechar:=linesize+1;
end
else
begin
if it then
stopinsert(false)
else
begin
it:=true;
st_change:=true;
if firstdisplay<=2 then
restorewindow;
templine^.linelength:=1;
insert(insertnl,templine);
if firstdisplay<=firstwindow then
begin
lineup;
updatestate:=allupdate;
end
else
begin
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
cury:=cury-1;
updatestate:=noupdate;
end;
curx:=filewindowÆcuryÅ^.linelength+1;
it:=true;
st_change:=true;
tc:=true;
file_updated:=true;
insertline:=cury;
putcursor(curx,cury-firstdisplay+1,false);
putcontrol(eraseeos,true);
end;
end;
end;
procedure jump_bottom;
var c:integer;
begin
stopinsert(true);
clearstatusline;
puthl("Moving to bottom#");
while (not eof(infile)) or (lastdisplay<lastwindow) do
c:=movedisplay(displaysize);
cury:= lastdisplay;
while (filewindowÆcuryÅ^.linelength = 0) and
(cury>firstwindow) do
lineup;
curx:= filewindowÆcuryÅ^.linelength+1;
end;
procedure jump_flag(cline:linie; var clinechar:integer);
var c,ypos:integer;
begin
stopinsert(true);
clearstatusline;
c:=getnumber(cline,clinechar,"Jump to flag number: $");
if go_on then
begin
if (c<0) or (c>11) then
attention("Illegal flag $")
else
begin
if c=10 then (* last window *)
ypos:=1+lastwindow-firstwindow+storedline
else
if c=11 then (* first window *)
ypos:=1+storedline
else
ypos:=flagsÆc,0Å;
if ypos<1 then
attention("Flag not set $")
else
begin
puthl("Moving to flag $");
putnumber(c,1,true);
puthl(" at line $");
putnumber(ypos,4,true);
putchnewbuf(' ');
if c<10 then
curx:=flagsÆc,1Å;
jumpline(ypos,true);
end;
end;
end;
end;
procedure jump_line(cline:linie; var clinechar:integer);
var c:integer;
begin
stopinsert(true);
clearstatusline;
c:=getnumber(cline,clinechar,"Jump to line: $");
if go_on then
begin
if c<1 then
c:=1;
puthl("Moving to line $");
putnumber(c,4,true);
putchnewbuf(' ');
jumpline(c,true);
end;
end;
procedure set_flag(cline:linie; var clinechar:integer);
var c,j:integer;
begin
c:=getnumber(cline,clinechar,"Set flag number: $");
if go_on then
begin
if (c<0) or (c>9) then
attention("Illegal flag $")
else
begin
if c=0 then
begin
j:=flagsÆ0,0Å+firstwindow-storedline-1;
if (j>=firstdisplay) and (j<=lastdisplay) then
begin
if updatestate=noupdate then
begin
update(j,j);
flagsÆ0,0Å:=0;
putdisplay;
end
else
update(j,j);
end;
if curx>lastinline then
curx:=curx-1;
fill_line;
update(cury,cury);
end;
flagsÆc,0Å:=1+cury+storedline-firstwindow;
flagsÆc,1Å:=curx;
end;
end;
end;
procedure set_mark;
var j:integer;
begin
j:=flagsÆ0,0Å+firstwindow-storedline-1;
if (j>=firstdisplay) and (j<=lastdisplay) then
begin
if updatestate=noupdate then
begin
update(j,j);
flagsÆ0,0Å:=0;
putdisplay;
end
else
update(j,j);
end;
if curx>lastinline then
curx:=curx-1;
fill_line;
update(cury,cury);
flagsÆ0,0Å:=1+cury+storedline-firstwindow;
flagsÆ0,1Å:=curx;
end;
procedure simplecommand( cline:linie;
var clinechar:integer);
var
commandch1,commandch2: iso;
c,xpos,ypos,j: integer;
sep: boolean;
procedure unknown;
var ch:iso;
begin
clearstatusline;
if xr then
begin
putcursor(lastinline-10,statusline,false);
put40("Line=$");
putnumber(xr_line,4,false);
putcursor(1,statusline,false);
end;
puthl("Unknown command: $");
if commandch1<' ' then
begin
putcontrol(highon,false);
if commandch1=nl then
putch(nldisplay)
else
if commandch1=ff then
putch(ffdisplay)
else
putch(controlch);
putcontrol(highoff,false);
end
else
putch(commandch1);
if commandch2>us then
putch(commandch2);
puthl(" Press <cr> to return $");
putch(bel);
putchnewbuf(bel);
ch:=getnext;
while ch<>cr do
ch:=getnext;
break:=true;
go_on:=false;
st_change:=true;
end;
begin (* simple command *)
commandch1:=clineÆclinecharÅ;
if (commandch1<='Z') and (commandch1>='A') then
commandch1:=chr(ord(commandch1)+32);
clinechar:=clinechar+1;
commandch2:=clineÆclinecharÅ;
if (commandch2<='Z') and (commandch2>='A') then
commandch2:=chr(ord(commandch2)+32);
clinechar:=clinechar+1;
case commandch1 of
'b' : case commandch2 of
'e' : begin
tc:=true;
file_updated:=true;
toregister(false,cline,clinechar,true,true);
end;
'i' : begin
tc:=true;
file_updated:=true;
registerinsert(cline,clinechar,true,false);
end;
'c' : toregister(false,cline,clinechar,true,false);
'm' : begin
tc:=true;
file_updated:=true;
toregister(true,cline,clinechar,true,false);
end;
'o' : begin
tc:=true;
file_updated:=true;
registerinsert(cline,clinechar,true,true);
end;
end otherwise unknown;
'c' : case commandch2 of
'b' : begin
tc:=true;
file_updated:=true;
cut_blanks(cline,clinechar);
end;
'm' : command_mode(cline,clinechar);
'i' : controlinfo;
'l' : charleft;
'r' : charright;
'f' : clear_flag(cline,clinechar);
end otherwise unknown;
'd' : case commandch2 of
'c' : begin
tc:=true;
file_updated:=true;
delchar;
end;
'k' : define_key(cline,clinechar);
'l' :
begin
tc:=true;
file_updated:=true;
stopinsert(false);
delete(curx,cury,1,0);
end;
'v' : inc_variable(cline,clinechar,false);
'w' : begin
tc:=true;
file_updated:=true;
delete_word;
end;
end otherwise unknown;
'e' :
case commandch2 of
'x','t','l','u','p','b','q':
exit_editor(commandch2,cline,clinechar);
end otherwise unknown;
'f' :
case commandch2 of
'c' : find_char(cline,clinechar);
'l' : find_newline;
'p' : find_page;
'm' : find_mark;
'n' : find_string(cline,clinechar,true);
's' : find_string(cline,clinechar,false);
end otherwise unknown;
'g' : case commandch2 of
'v' : get_value(cline,clinechar);
't' : get_time(cline,clinechar);
'd' : get_date(cline,clinechar);
'p' : get_parameter(cline,clinechar);
end otherwise unknown;
'h' :
begin
if (commandch2<'a') or (commandch2>'z') then
commandch2:='d';
help(commandch2);
end;
'?' : help('d');
'i' :
case commandch2 of
'b' : begin
tc:=true;
file_updated:=true;
insertchar(' ');
end;
'c' : begin
tc:=true;
file_updated:=true;
ic(cline,clinechar);
end;
'd' :
begin
id:= not id;
st_change:=true;
end;
'l','p' :
begin
tc:=true;
file_updated:=true;
stopinsert(false);
templine^.linelength:= 1;
if commandch2='l' then
insert(insertnl,templine)
else
insert(insertff,templine);
lineup;
curx:= filewindowÆcuryÅ^.linelength+1;
end;
'v' : inc_variable(cline,clinechar,true);
't' : insert_text(cline,clinechar);
end otherwise unknown;
'j' :
case commandch2 of
'b' : jump_bottom;
'f' : jump_flag(cline,clinechar);
'l' : jump_line(cline,clinechar);
's' :
begin
if (not it) and ((lastwindow-cury)<=(displaysize div 2)) then
begin
for i:=1 to (displaysize div 2) do
linedown;
for i:=1 to (displaysize div 2) do
lineup;
end;
putcursor(1,1,false);
putcontrol(eraseeos,false);
justifydisplay;
setstatusline;
end;
't' :
begin
stopinsert(true);
clearstatusline;
puthl("Moving to top#");
jumptop;
curx:=1;
end;
end otherwise unknown;
'l' :
case commandch2 of
'u' :
begin
if (cury=firstdisplay) and (controlsÆcursorupÅ.length=0) then
begin
ypos:=cury+storedline-firstwindow;
for j:=1 to overlap do
lineup;
jumpline(ypos,false)
end
else
lineup;
end;
'd' : linedown;
'm' : begin
updatestate:=allupdate;
nlm:= not nlm;
end;
's' : curx:=1;
'e' : curx:=filewindowÆcuryÅ^.linelength+1;
end otherwise unknown;
'n' :
case commandch2 of
'l' : new_line;
'o' :
begin
clearstatusline;
puthl("No operation$");
end;
'p' : next_page;
end otherwise unknown;
'p' :
case commandch2 of
'p' : prev_page;
'v' : put_variable(cline,clinechar);
end otherwise unknown;
'r' :
begin
stopinsert(false);
case commandch2 of
'c' : toregister(false,cline,clinechar,false,false);
'd' : registerdelete(cline,clinechar);
'i' : begin
tc:=true;
file_updated:=true;
registerinsert(cline,clinechar,false,false);
end;
'l' : registerlist(cline,clinechar);
'n' : registername;
'm' : begin
tc:=true;
file_updated:=true;
toregister(true,cline,clinechar,false,false);
end;
'r' : registerread(cline,clinechar);
'w' : registerwrite(cline,clinechar);
end otherwise unknown;
end;
's' :
case commandch2 of
'd' :
begin
stopinsert(true);
curx:=1;
if not lastinfile then
begin
linedown;
while filewindowÆcury-1Å^.attribute=nul do
linedown;
while emptyline and not lastinfile do
linedown;
end
else
begin
attention("Text end $");
end;
end;
'f' : set_flag(cline,clinechar);
'l' :
begin
linenumber:= not linenumber;
updatestate:=allupdate
end;
'm' : set_mark;
't' :
begin
stopinsert(false);
cury:=firstdisplay;
end;
'b' :
begin
if it then
begin
while cury<>lastdisplay do
linedown;
end
else
cury:=lastdisplay;
end;
'k' : show_key(cline,clinechar);
'p' : begin
if flagsÆ6,0Å < 1 then
attention("No previous find $")
else
begin
stopinsert(true);
clearstatusline;
puthl("Moving to 'start find' position $");
jumpline(flagsÆ6,0Å,true);
curx:=flagsÆ6,1Å;
end;
end;
'n' : begin
tc:=true;
file_updated:=true;
sub_string(cline,clinechar,true);
end;
's' : begin
tc:=true;
file_updated:=true;
sub_string(cline,clinechar,false);
end;
end otherwise unknown;
't' :
begin
case commandch2 of
'r' : tab_right;
'l' : tab_left;
'g' :
begin
tc:=true;
file_updated:=true;
stopinsert(false);
tabline^.attribute:=nl;
xpos:=curx;
curx:=1;
insert(insertlinekind,tabline);
curx:=xpos;
lineup;
end;
's' : tabline^:=filewindowÆcuryÅ^;
'm' :
with tabline^ do
begin
if linelength<curx then
begin
for xpos:=linelength+1 to curx do
lÆxposÅ:=' ';
linelength:=xpos;
end;
lÆcurxÅ:='!';
end;
'd' : tabline^.lÆcurxÅ:=' ';
end otherwise unknown;
end;
'u' :
begin
stopinsert(true);
case commandch2 of
's' : updatestate:= allupdate;
'l' : begin
if (cury>=firstdisplay) and (cury<=lastdisplay) then
update(cury,cury)
else
updatestate:=allupdate;
end;
end otherwise unknown;
putdisplay;
putcursor(curx,cury-firstdisplay+1,true);
end;
'w' :
begin
case commandch2 of
'l' : word_left;
'r' : word_right;
't' : begin
sep:=false;
get_string(cline,clinechar,"Write text: #",templine^,sep);
clearstatusline;
putcontrol(highon,false);
for j:=1 to templine^.linelength do
if templine^.lÆjÅ<' ' then
begin
if templine^.lÆjÅ=nl then
putch(nldisplay)
else
if templine^.lÆjÅ=ff then
putch(ffdisplay)
else
putch(controlch);
end
else
putch(templine^.lÆjÅ);
putcontrol(highoff,true);
end;
end otherwise unknown;
end;
'x' :
case commandch2 of
'k' :
begin
clearstatusline;
c:=getnumber(cline,clinechar,"Execute key number: $");
if c>255 then
attention("Illegal key number$")
else
if go_on then
with commandsÆcÅ do
command(l,linelength);
end;
'r' :
begin
execute_register(cline,clinechar);
end;
end otherwise unknown;
end otherwise unknown;
end; (* simplecommand *)
procedure command( cline:linie; last:integer);
var
p,clinechar,count,c,iterations,niveau: integer;
stop: boolean;
foundline: linie;
begin
level:=level+1;
if level=maxlevel then
begin
go_on:=false;
break:=true;
attention("Command level too deep $");
end;
clinechar:=1;
count:=1;
while (clinechar<=last) and go_on do
begin
case clineÆclinecharÅ of
'!' :
begin
count:=-1;
clinechar:=clinechar+1;
end;
'$' :
begin
count:=-2;
clinechar:=clinechar+1;
end;
'0','1','2','3','4','5','6','7','8','9','&','%' :
begin
count:=getnumber(cline,clinechar,"Repeat count: $");
end;
'<','(' :
begin
p:=clinechar+1;
niveau:=0;
stop:=false;
repeat
if p>last then
stop:=true
else
if clineÆclinecharÅ='<' then
begin
case clineÆpÅ of
'<' : niveau:=niveau+1;
'>' : if niveau=0 then
stop:=true
else
niveau:=niveau-1;
end otherwise;
end
else
begin
case clineÆpÅ of
'(' : niveau:=niveau+1;
')' : if niveau=0 then
stop:=true
else
niveau:=niveau-1;
end otherwise;
end;
p:=p+1;
until stop;
c:=1;
for iterations:=clinechar+1 to p-2 do
begin
foundlineÆcÅ:=clineÆiterationsÅ;
c:=c+1;
end;
foundlineÆcÅ:=cr;
clinechar:=p;
repeatcomm(foundline,c,count);
count:=1;
end;
' ' , ',' , '.' :
begin
clinechar:=clinechar+1;
count:=1;
end;
cr,';' :
begin
clinechar:=last+1;
end;
end (* case *)
otherwise
begin
simplecommand(cline,clinechar);
count:=1;
end;
end;
level:=level-1;
end; (* command *)
procedure init_editor;
begin (* Init editor *)
outch:=0;
break:=false;
new(templine);
new(tabline);
i:=claims;
getscopebase(bases);
initterminal;
setterminal(false,60,false);
if getsize<minsize then
begin
writeln(pname," Process too small. Min. size =",minsize:6);
terminate;
end;
if (i div 4096) < 4 then
begin
writeln(pname," Buffer claims too small");
terminate;
end;
if (i mod 4096) < 4 then
begin
writeln(pname," Area claims exceeded");
terminate;
end;
curx:=lastinline-1;
initfile(false);
putcursor(1,1,false);
putcontrol(eraseeos, false);
putcursor(20,04,false);
put40(sw_nr);
putcursor(26,05,false);
put40(release);
putch(nl);
while not eof(parmfile) do
begin
i:=0;
readline(parmfile,uplocalline,i,linesize);
for j:=1 to i do
putch(uplocallineÆjÅ);
if (parmfile^=nl) or (parmfile^=ff) then
begin
putch(parmfile^);
skipchar(parmfile);
end;
end;
close(parmfile);
putchnewbuf(nul);
for i:=1 to maxreg do regnamesÆiÅ.reg:= nullalfa;
windowsize:=round((getsize-minsize)/
((linesize/charsinword+10)*2))+3*displaysize;
(* Adding 20 extra halfwords to use by swop area, per line *)
if windowsize>maxwindowsize then
windowsize:=maxwindowsize;
windowstart:=windowsize-displaysize-6;
for i:=1 to windowsize do filewindowÆiÅ:=nil;
new(findline);
new(subfindline);
new(subinsertline);
new(templine);
templine^.linelength:=0;
firstwindow:= windowstart;
firstdisplay:= firstwindow;
lastdisplay:= firstdisplay+displaysize-1;
windowfill(firstwindow,true,true);
updatestate:= allupdate;
cury:= firstdisplay;
curx:= 1;
findline^.linelength:= 0;
subfindline^.linelength:= 0;
subinsertline^.linelength:= 0;
if cancel<>esc then
begin
canceltxt:="Ctrl X$";
canceltxtÆ6Å:=chr(ord(cancel)+64);
end
else
canceltxt:="Esc$";
for i:=0 to 9 do
begin
flagsÆi,0Å:=-1;
valuesÆiÅ.linelength:=0;
valuesÆiÅ.lÆ1Å:=cr;
end;
putcursor(1,1,false);
putcontrol(eraseeos,true);
end;
(*$r+*)
begin (* main *)
init_editor;
i:=reserveproc(curinname.procname);
with commandsÆ-1Å do
command(l,linelength);
repeat
if (updatestate<>noupdate) then
begin
putdisplay;
cursorupdate:=true;
end;
if st_change then
setstatusline;
if cursorupdate then
begin
putcursor(curx,cury-firstdisplay+1,true);
cursorupdate:=false;
end;
ch:= getnext;
if (ch>us) and (ch<del) then
(* all usual characters *)
begin
tc:=true;
file_updated:=true;
if curx > lastinline then
begin
fill_line;
with filewindowÆcuryÅ^ do
begin
templine^.attribute:= attribute;
attribute:= nul;
linelength:= lastinline;
end;
curx:= 1;
windowextend(1,cury,true);
if it and (firstdisplay<firstwindow+1) then
begin
stopinsert(false);
restorewindow;
templine^.linelength:=1;
insert(insertnl,templine);
cury:=cury-1;
filewindowÆcuryÅ^.linelength:=0;
insertline:=cury;
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
it:=true;
setstatusline;
end;
update(cury-1,cury);
with filewindowÆcuryÅ^ do
begin
attribute:= templine^.attribute;
linelength:= 1;
while (lookahead>us) and (lookahead<>del) do
begin
lÆlinelengthÅ:=ch;
ch:=getnext;
linelength:=linelength+1;
curx:=curx+1;
end;
justifylines(cury);
if cury=lastdisplay then
begin
clearstatusline;
update(lastdisplay-1,lastdisplay);
putchnewbuf(nl);
end
else
update(firstdisplay,cury+1);
end;
if (it and not(cury=lastdisplay)) then
begin
firstdisplay:=firstdisplay-1;
lastdisplay:=lastdisplay-1;
end;
end;
with filewindowÆcuryÅ^ do
begin
if curx>linelength then
begin
fill_line;
linelength:=curx;
end;
if (curx=flagsÆ0,1Å) and
(cury=(firstwindow+flagsÆ0,0Å-storedline-1)) then
mark_overwrite:=true;
lÆcurxÅ:= ch;
end;
curx:= curx + 1;
end
else
begin
if (line_ex and nlm) or mark_overwrite then
update(cury,cury);
line_ex:=false;
mark_overwrite:=false;
level:=0;
go_on:=true;
break:=false;
cont:=false;
error_start := false;
if ch=prefix then
begin
setstatusline;
putchnewbuf(nul);
ch:=getnext;
if (ch<=us) or (ch=del) then
begin
if ch=prefix then
c:=ord(prefix)
else
begin
nextinbuf:=nextinbuf-1;
c:=get_key_number;
end;
if (c>=0) and (c<>ord(cancel)) then
begin
with commandsÆc+128Å do
command(l,linelength);
end
else
putchnewbuf(bel);
end
else
if ch in Æ'0'..'9'Å then
begin
(*Hent antal gange udførelse *)
count:=ord(ch)-ord('0');
ch:=getnext;
if (ch=del) or (ch=bs) then
begin
putch(bel);
count:=0;
setstatusline;
ch:='0';
putchnewbuf(ch);
end;
while (ch>us) and go_on do
begin
if (ch in Æ'0'..'9'Å) then
begin
if count>99999 then
begin
attention("Repeat count too big $");
go_on:=false;
count:=0;
end
else
count:=count*10+(ord(ch)-ord('0'));
end
else
begin
attention("Illegal repeat count$");
go_on:=false;
count:=0;
end;
if go_on then
begin
ch:=getnext;
if (ch=del) or (ch=bs) then
begin
putch(bel);
count:=0;
setstatusline;
ch:='0';
putchnewbuf(ch);
end;
end;
end;
if go_on then
begin
nextinbuf:=nextinbuf-1;
c:=get_key_number;
if (c>=0) and (c<>ord(cancel)) then
begin
with commandsÆcÅ do
repeatcomm(l,linelength,count);
end
else
putchnewbuf(bel);
end;
end
else
begin
count:=1;
while (ch>us) and (ch<>del) do
begin
locallineÆcountÅ:=ch;
count:=count+1;
if not (locallineÆ1Å in Æ'?','a'..'z','A'..'Z'Å) then
begin
break:=true;
attention("Only a simple command allowed $");
ch:=cr;
count:=1;
updatestate:=allupdate;
end
else
if count>lastinline-20 then
begin
break:=true;
attention("Command line too long $");
ch:=cr;
count:=1;
updatestate:=allupdate;
end
else
ch:=getnext;
end;
if (ch=cancel) or (ch=del) or (ch=bs) then
begin
putchnewbuf(bel);
count:=1;
end;
locallineÆcountÅ:=cr;
command(localline,count);
end;
setstatusline;
end
else
begin
nextinbuf:=nextinbuf-1;
c:=get_key_number;
if (c>=0) and (c<>ord(cancel)) then
begin
with commandsÆcÅ do
command(l,linelength);
end
else
putchnewbuf(bel);
end;
cursorupdate:=true;
if eof(infile) then
while (filewindowÆlastwindowÅ^.linelength=0) and
(filewindowÆlastwindowÅ^.attribute=nl) and
(lastwindow>lastdisplay) do
lastwindow:=lastwindow-1;
end;
until false;
99:
end.
(*$r-*)
▶EOF◀