Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASEDIT.ZIP/EDT-MAIN.PAS

Pascal/Delphi Source File | 1988-07-29 | 24.3 KB | 644 lines

{  $LIST+, $DEBUG+, $BRAVE+, $LINESIZE:132,$PAGESIZE:77, $OCODE+   }
{  $MATHCK+, $RANGECK+, $INITCK+, $INDEXCK+, $ENTRY+    }
{  $LINE+, $RUNTIME+, $SYMTAB+, $WARN+, $GOTO+     }
{  $TITLE:'EDITOR .PAS -- AEM$SCRATCH'             }
{  $MESSAGE:'PASCAL - COMPILATION OPTIONS SET'     }
{  $MESSAGE:'SYSTEM - COMPILATION BEGINS'          }


PROGRAM EDITOR_CODE (EDFILE,INPUT,OUTPUT);

{  file contains the primary functions of the editor,  EDIT-MOD contains
   most of the code required for the command procedures and environment
   modification coding.   This must be linked to that module at OBJ time
   link time                                           }

{$I edit-mod}
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
   filename : string[14];
   filestats: char;
   command             :   commanddef;
   commandline         :   linedef;
   currentline,sentinel:   lineptr;
   edfile              :   text;
   isitacommand, legalcommand, noerror, running, verify : boolean;
   ordinal : integer;
   tablecommands : commandtable;


procedure endxqq; external;  {  library function to terminate  }
procedure cls; external;
function min ( x, y : integer) : integer; external;
procedure readline (var line : linedef);  external;
procedure insertline (currentline, newline : lineptr); external;
procedure packline (line : linedef; packedline : lineptr);    external;
procedure readfile (var currentline, sentinel : lineptr);    external;
procedure errormessage (var noerror : boolean; message : messagetype); external;
procedure removetrailingblanks (var line : linedef);   external;
procedure checkempty (sentinel : lineptr; var noerror : boolean);  external;
procedure readcommand (prompt : char; var line : linedef);    external;
procedure skipblanks (var line : linedef);   external;
procedure movelinepointer (var currentline : lineptr; linestomove : integer;
                           sentinel : lineptr; var noerror : boolean); external;
function numeric ( ch : char) : boolean;  external;
procedure getnumber (var line : linedef; var number : integer;
                 var legalnumber : boolean);     external;
procedure processprefix (var commandline : linedef; var currentline : lineptr;
                     sentinel : lineptr; var noerror : boolean); external;
function alphabetic (ch : char) : boolean;  external;
procedure getcommand(var commandline : linedef; var command : commanddef;
                     var legalcommand, noerror : boolean); external;
procedure commandordinal (command : commanddef; var ordinal : integer;
                      var tablecommands : commandtable; var noerror : boolean); external;
procedure endparse (commandline : linedef; var noerror : boolean); external;
procedure getstring (var commandline : linedef; var strng : stringdef;
                     var legalstring : boolean); external;
procedure unpackline(var line : linedef; pline : lineptr);  external;
procedure stringin(var line : linedef; strng : stringdef;
                   var commandline : linedef; var found : boolean);   external;
procedure locate (strng : stringdef; var pline : lineptr;
                   var count :integer; increment : integer; sentinel : lineptr;
                   var commandline : linedef; var noerror : boolean);  external;
procedure getparameter(var commandline : linedef; sentinel : lineptr;
                       var count : integer; var noerror : boolean);  external;
procedure printline(line : linedef); external;
procedure printpackedline (pline : lineptr); external;
procedure freetext (pline : lineptr);  external;
procedure deleteline (pline : lineptr); external;



procedure readdataline (var line, commandline : linedef; var isitacommand : boolean);
begin
   readcommand ('*',line);
   if (line.length >0 ) and (line.chars[1] = '\') then
       begin
           isitacommand := true;
           line.position := 2;
           commandline := line
       end
end;  { procedure  }

procedure abortt (commandline : linedef; var noerror : boolean; var running : boolean);
begin
   endparse (commandline,noerror);
   if noerror then
       begin
           running := false;
           errormessage(noerror, 'EDIT ABORTED.  FILE UNCHANGED')
       end
end;  { abort  }

procedure append (var commandline :  linedef; currentline : lineptr;
                   sentinel : lineptr; verify : boolean; var noerror : boolean);
var
   charnum : linelengthdef;   truncated, column : integer;
   legalnumber, legalstring : boolean;   scratchline : linedef;
   strng:stringdef;
begin
   unpackline(scratchline,currentline);
   getstring(commandline,strng,legalstring);
   if legalstring then
       begin
           with commandline do
               if position <= length then position := position + 1;
           getnumber (commandline,column,legalnumber);
           if not legalnumber then column := scratchline.length + 1
       end
   else errormessage (noerror,'STRING FIELD NOT SEEN');
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   if noerror and (column <= 0) or (column > maxchars) then
           errormessage (noerror, 'COLUMN POSITION OUT OF RANGE');
   if noerror and (strng.length > 0) then
       begin
           if (column + strng.length - 1 ) > maxchars then
               begin
                   truncated := column + strng.length -1 - maxchars;
                   strng.last := strng.last-truncated;
                   strng.length := strng.length - truncated;
                   errormessage (noerror, 'LINE TRUNCATED -- TOO LONG');
                   noerror := true
               end;
           if strng.length > 0 then
               begin
                   for charnum := 0 to scratchline.length -1 do
                       scratchline.chars[column+charnum] := commandline.chars[strng.first+charnum];
                   scratchline.length := column+strng.length-1;
                   packline(scratchline,currentline)
               end;
           if verify then printline (scratchline)
       end
end;  { procedure }
procedure bottom (var commandline : linedef; var currentline : lineptr;
                   sentinel : lineptr; verify : boolean; var noerror : boolean);
begin
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   if noerror then
       begin
           currentline := sentinel^.previousline;
           if verify then printpackedline(currentline);
           writeln ('*EOF')
       end
end;  { proc }

procedure change (var commandline : linedef; currentline, sentinel : lineptr;
                   verify : boolean; var noerror : boolean);
var
   index :integer;  legal1string, legal2string,stringthere :boolean;
   scratch1line,scratch2line : linedef;
   string1,string2 : stringdef;
begin
   getstring (commandline,string1,legal1string);
   getstring (commandline,string2,legal2string);
   if legal1string and legal2string then
       begin
           commandline.position := commandline.position + 1;
           endparse(commandline,noerror);
           checkempty(sentinel,noerror);
           if noerror then
               begin
                   unpackline(scratch1line,currentline);
                   stringin(scratch1line,string1,commandline,stringthere);
                   if stringthere then
                     begin
                       if scratch1line.position > 1 then
                       begin
                           for index := 1 to scratch1line.position -1 do
                               scratch2line.chars[index]:=scratch1line.chars[index];
                           scratch2line.position := scratch1line.position - 1
                       end
                   else scratch2line.position := 0;
                   if string2.length > 0 then
                     begin
                       for index := string2.first to string2.last do
                       begin
                           scratch2line.position := scratch2line.position+1;
                           scratch2line.chars[scratch2line.position] := commandline.chars[index]
                       end
                     end;
                   scratch1line.position := scratch1line.position + string1.length;
                   if scratch1line.position = 0 then scratch1line.position := 1;
                   while scratch1line.position <= scratch1line.length do
                       begin
                           scratch2line.position := scratch2line.position+1;
                           scratch2line.chars[scratch2line.position] := scratch1line.chars[scratch1line.position];
                           scratch1line.position := scratch1line.position +1
                       end;
                   scratch2line.length := scratch2line.position;
                   packline(scratch2line,currentline);
                   if verify then printline(scratch2line);
                   writeln ('*** CHANGED')
               end
           else errormessage (noerror, 'STRING NOT FOUND')
         end
       end
   else errormessage (noerror,'INVALID PARAMETER')
end;  { procedure change  }

procedure delete(var commandline:linedef; var currentline:lineptr;
                   sentinel : lineptr; verify : boolean; var noerror : boolean);
var
   count, increment : integer;   pline : lineptr;
   delcount : integer;
begin
   getparameter(commandline,sentinel,count,noerror);
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   delcount := abs (count);
   if noerror then
       begin
           if count > 0 then increment := 1 else increment := -1;
           while (count <> 0) and noerror do
               begin
                   pline := currentline;
                   if verify then printpackedline(pline);
                   movelinepointer(currentline,increment,sentinel,noerror);
                   count:=count-increment;
                   deleteline(pline)
               end;
           if not noerror then
               if increment > 0 then currentline := sentinel^.previousline
           else currentline := sentinel^.nextline
       end;
   writeln ('*** ', delcount : 1, '  LINES DELETED')
end;

procedure equal (var commandline : linedef; var currentline : lineptr);
var
   index, newposition : linelengthdef;  pline : lineptr;
begin
   with commandline do
       begin
           if position <= length then
               begin
                   newposition := 0;
                   for index := position to length do
                       begin
                           newposition := newposition + 1;
                           chars[newposition]:=chars[index]
                       end;
                   length := newposition
               end
           else length := 0;
           new (pline);
           packline (commandline,pline);
           insertline(currentline,pline);
           currentline := pline
       end; { with }
   writeln ('*** LINE REPLACED')
end;  { proc }

procedure find (var commandline : linedef; var currentline : lineptr;
               sentinel : lineptr; verify : boolean; var noerror : boolean);
var
   count,increment :integer; legalstring:boolean;
   pline:lineptr; strng:stringdef;
begin
   with commandline do
       begin
           if (chars[position]='-') and (position <= length) then
               begin
                   increment := -1;
                   position := position + 1
               end
           else increment := 1
   end;
   getstring(commandline,strng,legalstring);
   if legalstring then
       begin
           commandline.position := commandline.position+1;
           endparse(commandline,noerror);
           checkempty(sentinel,noerror);
           if noerror then
               begin
                   pline := currentline;
                   locate (strng,pline,count,increment,sentinel,commandline,noerror);
                   if noerror then
                       begin
                           currentline := pline;
                           if verify then printpackedline(currentline)
                       end
               end
   end
   else
       errormessage (noerror,'INVALID PARAMETER')
end; { find procedure }

procedure header (var commandline : linedef; var noerror : boolean);
var
   index, width : integer;  legalnumber : boolean;
begin
   getnumber(commandline,width,legalnumber);
   if not legalnumber then
         width := 72;
   endparse(commandline,noerror);
   if (width > 0) and noerror then
       begin
           write ('  |');   {  move out of prompt area  }
           for index := 1 to width do
                write (index mod 10 : 1);
           writeln  ('|')
       end
end;  { proc  }

procedure insert (var commandline:linedef;var currentline:lineptr;
                   sentinel:lineptr;var isitacommand :boolean; var noerror : boolean);
var
   pline : lineptr; scratchline : linedef;
begin
   cls;
   writeln ('MODE> ...INSERT');
   endparse(commandline,noerror);
   if noerror then
       begin
           while not isitacommand do
               begin
                   readdataline(scratchline,commandline,isitacommand);
                   with scratchline do
                    begin
                       if not isitacommand then
                       begin
                           new(pline);
                           packline(scratchline,pline);
                           insertline(currentline,pline);
                           currentline := currentline^.nextline
                       end
                     end
           end
       end;
   writeln ('MODE> COMMAND')
end;  {proc }

procedure next(var commandline:linedef;var currentline:lineptr;
               sentinel:lineptr;verify:boolean;var noerror :boolean);
var
   count :integer;  legalnumber :boolean;
begin
   getnumber(commandline,count,legalnumber);
   if not legalnumber then count := 1;
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   if noerror then
       begin
           movelinepointer(currentline,count,sentinel,noerror);
           if verify then printpackedline(currentline)
       end
end;

procedure print(var commandline:linedef;var currentline:lineptr;
                sentinel:lineptr;verify :boolean;var noerror:boolean);
var
   count,increment:integer;
begin
   getparameter(commandline,sentinel,count,noerror);
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   if noerror then
       begin
           if count < 0 then increment := -1 else increment := 1;
           printpackedline(currentline);
           count:=count-increment;
           while (count <> 0) and noerror do
               begin
                   movelinepointer(currentline,increment,sentinel,noerror);
                   count:=count-increment;
                   if noerror then printpackedline(currentline)
               end
   end
end;  { proc  }

procedure replace(var commandline:linedef;var currentline:lineptr;
                   sentinel:lineptr;var isitacommand:boolean;var noerror:boolean);
var
   firstline:boolean; scratchline:linedef;
begin
   writeln ('MODE> ...REPLACE');
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   firstline:=true;
   while (not isitacommand) and noerror do
       begin
           readdataline(scratchline,commandline,isitacommand);
           if not isitacommand then
               begin
                   if firstline then firstline := false
                   else movelinepointer(currentline,1,sentinel,noerror);
                   freetext(currentline);
                   packline(scratchline,currentline);
                   if currentline=sentinel^.previousline then
                   errormessage (noerror,'END OF INPUT FILE')
               end
       end;
   writeln ('MODE> COMMAND')
end;  { proc  }

procedure stop (var commandline:linedef;sentinel:lineptr;
               var running,noerror : boolean);
var
   currentline:lineptr;  index:integer;  scratchline:linedef;
   linecount : integer;
begin
   endparse(commandline,noerror);
   if noerror then
       begin
           cls;
           linecount := 0;
           rewrite(edfile);
           currentline := sentinel;
           checkempty(sentinel,noerror);
           if noerror then
               begin
                   repeat
                       linecount := linecount + 1;
                       currentline := currentline^.nextline;
                       unpackline(scratchline,currentline);
                       for index := 1 to scratchline.length do
                           write(edfile,scratchline.chars[index]);
                       writeln(edfile)
                   until currentline=sentinel^.previousline
               end;
           running := false;
           write ('EDIT FILE: ', filename, '  ');
          errormessage (noerror,' REPLACED ***')
       end;
   writeln ('*** ',linecount : 1, '  LINE(S) SAVED')
end; {stop}

procedure top(var commandline:linedef;var currentline:lineptr;
               sentinel:lineptr;verify:boolean;var noerror:boolean);
begin
   endparse(commandline,noerror);
   checkempty(sentinel,noerror);
   if noerror then
       begin
           currentline:= sentinel^.nextline;
           writeln ('*TOF');
           if verify then printpackedline(currentline)
       end
end; {proc}

procedure verifyflag(var commandline:linedef;sentinel:lineptr;
                     var verify:boolean; var noerror:boolean);
var
   command:commanddef;  legalcommand:boolean;
begin
   skipblanks(commandline);
   getcommand(commandline,command,legalcommand,noerror);
   if(commandline.position > commandline.length) or (not noerror) then
       begin  { set flag }
           endparse(commandline,noerror);
           if noerror then
               begin
                  verify := not verify;
                  writeln ('*CHANGED');
                  if verify then writeln ('VERIFY SET') else writeln ('VERIFY NOT SET')
               end
       end
   else
       begin
           endparse(commandline,noerror);
           if noerror then
               begin
                   if command.chars='on     ' then verify := on
                   else if command.chars='off    ' then verify := off
                   else errormessage (noerror, 'INVALID SWITCH PARAMETER')
               end
       end
end; {proc}

begin  { main module }
   cls;
   noerror := true;
   writeln;
   writeln;
   write ('Input filename to edit:  (Include drive spec) ==> ');
   readln (filename);
   writeln;
   write('[N]ew or [E]xisting file?  ==> ');
   readln (filestats);
   if filestats in ['E','e'] then
       begin
           assign(edfile,filename);
           reset(edfile)
       end
   else if filestats in ['N','n'] then
           begin
               writeln ('New File');
               writeln ('Files cannot be created with V1.10');
               writeln ;
               writeln ('Insert procedure will FAIL');
               writeln;
               writeln
       end
   else begin
           writeln ('File select error, Restart');
           writeln;
           endxqq;
           noerror := false
        end;
   writeln ('Editor :  Version: V1.1; PASCAL source');
   writeln ;
   writeln ('Execution begins...');
   writeln ;
   writeln ('VERIFY is set');
   writeln;
   writeln ('MODE> COMMAND');
   writeln;
   if noerror then noerror := true;
   writeln;
   writeln ('READING: ', filename, '       >>> WAIT ');
   readfile(currentline,sentinel);
   writeln ('*GO');
   writeln;
   checkempty(sentinel,noerror);
   currentline := sentinel^.nextline;
   isitacommand := false;
   running := true;
   verify := on;
   with tablecommands do
     begin
       shortcommands[1]:='d';
       shortcommands[2]:='i';
       shortcommands[3]:='p';
       shortcommands[4]:='c';
       shortcommands[5]:='r';
       shortcommands[6]:='f';
       shortcommands[7]:='s';
       shortcommands[8]:='v';
       shortcommands[9]:='b';
       shortcommands[10]:='n';
       shortcommands[11]:='t';
       shortcommands[12]:='a';
       shortcommands[13]:='h';
       shortcommands[14]:='=';
       shortcommands[15]:=' ';
       shortcommands[16]:=' ';
       shortcommands[17]:=' ';
       shortcommands[18]:=' ';
       longcommands[1]:='delete ';
       longcommands[2]:='insert ';
       longcommands[3]:='print  ';
       longcommands[4]:='change ';
       longcommands[5]:='replace';
       longcommands[6]:='find   ';
       longcommands[7]:='stop   ';
       longcommands[8]:='verify ';
       longcommands[9]:='bottom ';
       longcommands[10]:='next   ';
       longcommands[11]:='top    ';
       longcommands[12]:='append ';
       longcommands[13]:='header ';
       longcommands[14]:='       ';
       longcommands[15]:='       ';
       longcommands[16]:='abort  ';
       longcommands[17]:='       ';
     end; { with }
   while running do
       begin
           noerror := true;
           if isitacommand then isitacommand:=false
           else readcommand('>',commandline);
           processprefix(commandline,currentline,sentinel,noerror);
           if noerror then
               begin
                   getcommand(commandline,command,legalcommand,noerror);
                   if noerror then
                       begin
                           commandordinal(command,ordinal,tablecommands,noerror);
                           if noerror then
                               case ordinal of
                                   1:delete(commandline,currentline,sentinel,verify,noerror);
                                   2:insert(commandline,currentline,sentinel,isitacommand,noerror);
                                   3:print(commandline,currentline,sentinel,verify,noerror);
                                   4:change(commandline,currentline,sentinel,verify,noerror);
                                   5:replace(commandline,currentline,sentinel,isitacommand,noerror);
                                   6:find(commandline,currentline,sentinel,verify,noerror);
                                   7:stop(commandline,sentinel,running,noerror);
                                   8:verifyflag(commandline,sentinel,verify,noerror);
                                   9:bottom(commandline,currentline,sentinel,verify,noerror);
                                  10:next(commandline,currentline,sentinel,verify,noerror);
                                  11:top(commandline,currentline,sentinel,verify,noerror);
                                  12:append(commandline,currentline,sentinel,verify,noerror);
                                  13:header(commandline,noerror);
                                  14:equal(commandline,currentline);
                                  16:abortt(commandline,noerror,running)
                               end
                       end
               end
       end;
   writeln;  writeln;  writeln;
   writeln ('Editor:  Version V1.1  --  Normal completion');
   writeln ;
   writeln ('Control restored to SYSTEM ')
end.