home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
USCX
/
STEVEUT.ZIP
/
EDIT-MOD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1984-05-19
|
21KB
|
614 lines
{ $LIST+, $DEBUG+, $BRAVE+, $LINESIZE:132, $PAGESIZE:77, $OCODE+ }
{ $NILCK+, $MATHCK+, $RANGECK+, $INITCK+, $INDEXCK+, $ENTRY+ }
{ $LINE+, $RUNTIME+, $SYMTAB+, $WARN+, $GOTO+ }
{ $TITLE:'EDITOR MODULE: MODULE.PAS - AEM$SCRATCH ' }
{ $MESSAGE:'PASCAL - COMPILATION OPTIONS SET' }
{ $MESSAGE:'SYSTEM - COMPILATION BEGINS' }
{ $message:'PASCAL - MODULE COMPILATION LINKAGE SET' }
MODULE SUPPLEMENTAL_COMMANDS;
const
charspernode = 34;
debug = true;
maxcharp1 = 201;
maxchars = 200;
maxcommandlength = 7;
numberlongcommands =17;
numbershortcommands =18;
off = false;
on = true;
type
linecharptr = ^linecharnode;
lineptr = ^lineptrnode;
lineptrnode = record
length : 0 .. maxchars;
nextline: lineptr;
previousline : lineptr;
firstnode : linecharptr
end; { record }
linecharnode = record
nextnode : linecharptr;
chars : packed array [ 1 .. charspernode] of char
end; { record }
linelengthdef = 0 .. maxchars;
linedef = record
length : linelengthdef;
position : 0 .. maxcharp1;
chars : array [ 1 .. maxcharp1] of char
end; { record }
messagetype = lstring (30);
commanddef = record
length : linelengthdef;
position: 0 .. maxcharp1;
chars : packed array [ 1 .. maxcommandlength] of char
end; { record }
stringdef = record
first : 0 .. maxcharp1;
last : linelengthdef;
length : linelengthdef
end;
commandtable = record
shortcommands : array [ 1 .. numbershortcommands ] of char;
longcommands : array [ 1 .. numberlongcommands ] of
packed array [ 1 .. maxcommandlength ] of char
end; { record }
var [extern]
edfile : text;
currentline : lineptr;
function min ( x, y : integer) : integer;
begin
if x < y then min := x else min := y
end; { function }
procedure readline (var line : linedef);
begin
with line do
begin
length := 0;
while not eoln (edfile) do
begin
length := length + 1;
read (edfile, chars[length])
end { eoln }
end; { with }
readln (edfile)
end; { procedure }
procedure insertline (currentline, newline : lineptr);
begin
newline^.nextline := currentline^.nextline;
newline^.previousline := currentline;
newline^.nextline^.previousline := newline;
currentline^.nextline := newline
end; { insertline }
procedure packline (line : linedef; packedline : lineptr);
var
charnum : 1 .. charspernode;
charspacked : integer;
node, oldnode : linecharptr;
begin
packedline^.length := line.length;
if line.length <> 0 then
begin
new (node);
packedline^.firstnode := node;
for charnum := 1 to min (line.length,charspernode) do
node^.chars [charnum] := line.chars [charnum];
charspacked := charspernode;
while charspacked < line.length do
begin
oldnode := node;
new (node);
oldnode^.nextnode := node;
for charnum := 1 to min (line.length-charspacked,charspernode) do
node^.chars [charnum] := line.chars [charspacked+charnum];
charspacked := charspacked+charspernode
end; { while }
node^.nextnode := nil
end
else
packedline^.firstnode := nil
end; { procedure packline }
procedure readfile (var currentline, sentinel : lineptr);
var
line : linedef; { scratch buffer }
newline : lineptr; { new line to insert }
begin
reset (edfile);
new(currentline);
sentinel := currentline;
with sentinel^ do
begin
length := 0;
previousline := currentline;
nextline := currentline;
firstnode := nil
end;
while not eof (edfile) do
begin
readline (line);
new (newline);
insertline (currentline,newline);
currentline := newline;
packline (line,currentline)
end { while }
end; { procedure }
procedure errormessage (var noerror : boolean; message : messagetype);
begin
writeln ('*** ',message);
noerror := false
end; { error handler }
procedure checkempty (sentinel : lineptr; var noerror : boolean);
begin
if noerror and (sentinel^.nextline = sentinel) then
errormessage (noerror, 'EDIT FILE EMPTY')
end; { check empty }
procedure removetrailingblanks (var line : linedef);
var
done : boolean;
index : integer;
begin
with line do
begin
done := false;
index := 1;
while not done and (index <= length) do
if chars[index] <> ' ' then
index := index + 1
else
done := true;
if done then
length := index;
position := 1;
chars[length+1] := ' ';
if (length = 0) then length := 1
end { with }
end; { procedure }
procedure readcommand (prompt : char; var line : linedef);
begin
with line do
begin
write (prompt,' ');
length := 0; { assume null command on input }
while not eoln do
begin
length := length + 1;
read (chars [length])
end;
if prompt = '>' then
removetrailingblanks (line) { skip proc call }
end; { if inserting lines }
readln;
writeln
end; { procedure }
procedure skipblanks (var line : linedef);
begin
with line do
begin
while (position <= length) and (chars [position] = ' ') do
position := position + 1
end { while }
end; { procedure }
procedure movelinepointer (var currentline : lineptr; linestomove : integer;
sentinel : lineptr; var noerror : boolean);
var
bottomoffile,topoffile : lineptr;
begin
checkempty (sentinel, noerror);
if noerror then
begin
topoffile := sentinel^.nextline;
bottomoffile := sentinel^.previousline;
while ((currentline <> topoffile) and (linestomove < 0)) or
((currentline <> bottomoffile) and (linestomove > 0)) do
begin
if linestomove < 0 then
begin
linestomove := linestomove +1 ;
currentline := currentline^.previousline
end
else
begin
linestomove := linestomove - 1 ;
currentline := currentline^.nextline
end
end; { while }
if linestomove <> 0 then
if linestomove > 0 then
errormessage (noerror, 'END OF INPUT FILE')
else
errormessage (noerror, 'TOP OF INPUT FILE')
end
end; { procedure }
function numeric ( ch : char) : boolean;
begin
numeric := (ch >= '0') and (ch <= '9')
end; { function }
procedure getnumber (var line : linedef; var number : integer;
var legalnumber : boolean);
var
sign : integer;
begin
number := 0;
legalnumber := false;
skipblanks (line);
with line do
begin
if position <= length then
begin
if chars [position] = '!' then
begin
position := position + 1;
number := maxint;
legalnumber := true
end
else
begin
sign := 1;
if chars [position] = '-' then
begin
sign := -1;
position := position + 1
end
else
if chars [position] = '+' then
begin
sign := 1;
position := position + 1
end;
while (position <= length) and numeric(chars[position]) do
begin
number := 10*number+ord(chars[position])-ord('0');
position := position + 1;
legalnumber := true
end;
number := sign * number
end
end
end
end; { procedure }
procedure processprefix (var commandline : linedef; var currentline : lineptr;
sentinel : lineptr; var noerror : boolean);
var
bottomoffile, topoffile : lineptr;
stillprefix,legalnumber : boolean;
number : integer;
begin
bottomoffile := sentinel^.previousline;
topoffile := sentinel^.nextline;
skipblanks (commandline);
with commandline do
begin
if (position <= length) and (chars[position] <>'=') then
begin
stillprefix := true;
while (position <= length) and stillprefix and noerror do
begin
if chars [position] = '!' then
begin
currentline := bottomoffile;
checkempty (sentinel,noerror)
end
else
if (chars[position]='+') or (chars[position]='-') then
begin
getnumber(commandline,number,legalnumber);
if legalnumber then
movelinepointer(currentline,number,sentinel,noerror)
else
errormessage (noerror,'ILLEGAL SYMBOL IN PREFIX');
stillprefix := false
end
else
if chars[position]='^' then
begin
checkempty(sentinel,noerror);
currentline := topoffile
end
else
if (chars[position] <> ' ') then stillprefix := false;
if stillprefix then position := position + 1
end
end
end
end; { procedure }
function alphabetic (ch : char) : boolean;
begin
alphabetic := (ch >= 'a') and (ch <= 'z')
end; { function }
procedure getcommand(var commandline : linedef; var command : commanddef;
var legalcommand, noerror : boolean);
var
commandchar : integer;
begin
command.length := 0;
skipblanks (commandline);
legalcommand := true;
for commandchar := 1 to maxcommandlength do
command.chars[commandchar] := ' ';
with commandline do
begin
if position > length then
begin
legalcommand := true;
command.chars [1] := 'p'; { assume null, print command }
command.length := 1
end
else
if not (alphabetic(chars[position]) or numeric(chars[position])) then
begin
legalcommand := true;
command.chars[1] := 'f'; { assume delimiter, find command }
command.length := 1
end
else if chars[position] = '=' then
begin { process equals command }
legalcommand := true;
command.chars[1] := '=';
command.length := 1;
position := position + 1
end
else { build a normal command, other than default }
begin
while alphabetic(chars[position]) and (position <= length) and noerror do
begin
if command.length < maxcommandlength then
begin
command.length := command.length + 1;
command.chars[command.length] := chars[position];
position := position + 1;
legalcommand := true
end
else { bad input line }
errormessage (noerror, 'NO SUCH COMMAND')
end { while }
end
end { with }
end; { procedure }
procedure commandordinal (command : commanddef; var ordinal : integer;
var tablecommands : commandtable; var noerror : boolean);
var
index : integer;
begin
index := 1;
if command.length = 1 then
begin
tablecommands.shortcommands[numbershortcommands] := command.chars[1];
while command.chars[1] <> tablecommands.shortcommands[index] do
index := index + 1;
if index = numbershortcommands then
errormessage (noerror, 'NO SUCH COMMAND')
end
else
begin
tablecommands.longcommands[numberlongcommands] := command.chars;
while command.chars <> tablecommands.longcommands[index] do
index := index + 1;
if index = numberlongcommands then
errormessage (noerror, 'NO SUCH COMMAND')
end; { if }
ordinal := index
end; { procedure }
procedure endparse (commandline : linedef; var noerror : boolean);
begin
if noerror then
begin
skipblanks (commandline);
if commandline.position <= commandline.length then
errormessage (noerror, 'INVALID COMMAND PARAMETER')
end { if }
end; { procedure }
procedure getstring (var commandline : linedef; var strng : stringdef;
var legalstring : boolean);
var
delimiter : char;
begin
skipblanks (commandline);
legalstring := false;
strng.length := 0;
with commandline do
if position <= length then begin
begin
if (not alphabetic(chars[position])) and (not numeric(chars[position])) and
(chars[position] <> '+') and (chars[position] <> '-') and (chars[position] <> '!') then
begin
delimiter := chars[position];
legalstring := true;
position := position + 1;
strng.first := position;
while (chars[position] <> delimiter) and (position <= length) do
position := position +1 ;
strng.last := position -1;
strng.length := strng.last - strng.first + 1
end
end
end; { if position }
if strng.length = 0 then
begin
strng.first := 1;
strng.last := 0
end
end; { procedure }
procedure unpackline(var line : linedef; pline : lineptr);
var
charnum : 1 .. charspernode;
node : linecharptr;
unpackcount : integer;
begin
with line do
begin
length := pline^.length;
if length <> 0 then
begin
node := pline^.firstnode;
unpackcount := 0;
repeat
for charnum := 1 to min(charspernode,length-unpackcount) do
chars[unpackcount+charnum] := node^.chars[charnum];
unpackcount := unpackcount + charspernode;
node := node^.nextnode
until node = nil
end { if }
end { with }
end; { procedure }
procedure stringin(var line : linedef; strng : stringdef;
var commandline : linedef; var found : boolean);
var
done,stringthere : boolean; index : integer;
begin
line.position := 0;
if strng.length = 0 then stringthere := true
else
begin
with line do
begin
stringthere := false;
done := false;
chars[length+1] := commandline.chars[strng.first];
repeat
position := position + 1;
if (position+strng.length-1) > length then
begin
done := true
end
else
begin
stringthere := true;
index := strng.first;
while stringthere and (index <= strng.last) do
begin
if commandline.chars[index] <> line.chars[line.position+index-strng.first] then
stringthere := false
else index := index + 1
end
end
until done or stringthere
end { with }
end; { if }
found := stringthere
end; { procedure }
procedure locate (strng : stringdef; var pline : lineptr;
var count :integer; increment : integer; sentinel : lineptr;
var commandline : linedef; var noerror : boolean);
var
found : boolean; scratchline : linedef;
begin
found := false;
count := increment;
repeat
movelinepointer(pline,increment,sentinel,noerror);
count := count + increment;
if noerror then
begin
unpackline(scratchline,pline);
stringin(scratchline,strng,commandline,found)
end
until found or (not noerror)
end; { procedure }
procedure getparameter(var commandline : linedef; sentinel : lineptr;
var count : integer; var noerror : boolean);
var
legalnumber, legalstring : boolean;
sign : integer; pline : lineptr; strng : stringdef;
begin
with commandline do
begin
if position <= length then
begin
if chars[position]='-' then
begin
sign := -1;
position := position + 1
end
else sign := 1;
getstring(commandline,strng,legalstring);
if legalstring then
begin
position := position + 1;
pline := currentline;
locate(strng,pline,count,sign,sentinel,commandline,noerror)
end
else
begin
getnumber(commandline,count,legalnumber);
if legalnumber then count := count*sign else count := sign
end
end
else count := 1
end
end; { procedure }
procedure printline(line : linedef);
var charnum : linelengthdef;
begin
for charnum := 1 to line.length do write (line.chars[charnum]);
writeln
end;
procedure printpackedline (pline : lineptr);
var
index : linelengthdef; scratchline : linedef;
begin
unpackline(scratchline,pline);
printline (scratchline)
end;
procedure freetext (pline : lineptr);
var
node, nodegone : linecharptr;
begin
node := pline^.firstnode;
pline^.length := 0;
pline^.firstnode := nil;
while node <> nil do
begin
nodegone := node;
node := nodegone^.nextnode;
dispose (nodegone)
end { while }
end; { proc }
procedure deleteline (pline : lineptr);
begin
pline^.previousline^.nextline := pline^.nextline;
pline^.nextline^.previousline := pline^.previousline;
freetext (pline);
dispose (pline)
end; { delete }
end. { module }