Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASEDIT.ZIP/EDIT-MOD.PAS

Pascal/Delphi Source File | 1988-07-29 | 20.6 KB | 611 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' }



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 = string[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
   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
           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  }