Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PLIST.ZIP/PLIST.PAS

Pascal/Delphi Source File | 1984-12-23 | 25.6 KB | 756 lines

program PLIST;
(*
  Written by: Rick Schaeffer
              E. 13611 26th Av.
              Spokane, Wa.  99216

  modifications (7/8/84  by Len Whitten, CIS: [73545,1006])
     1) added error handling if file not found
     2) added default extension of .PAS to main & include files
     3) added "WhenCreated" procedure to extract file
        creation date & time from TURBO FIB
     4) added demarcation of where include file ends
     5) added upper char. conversion to include file
     6) increased left margin to 5 spaces (80 char. line just fits @ 10cpi)
     7) added listing control: {.L-} turns it off, {.L+} turns it back on,
        must be in column 1

  further modifications (7/12/84 by Rick Schaeffer)
     1) cleaned up the command line parsing routines and put them in
        separate procedures.  Now permits any number of command line
        arguments, each argument separated with at least one space.
     2) added support for an optional second command line parameter
        which specifies whether include files will be listed or not.
        The command is invoked by placing "/i" on the command line
        at least one space after the file name to be listed.  For
        instance, to list MYPROG.PAS as well as any "included" files,
        the command line would be: PLIST MYPROG /I

   further modification (8/28/84) by Jay Kadashaw)
      1) Restored filedate and filetime after listing an included
         file.
      2) Added comment counter and begin/end counter.
      3) Output can be routed to either the printer or console.
      4) After listing first file the user is prompted for next
         file if any.

   Still more modifications! (10/30/84) by Michael Roberts
         1) Cleaned Up various problems I encountered
         2) Removed Comment counter in order to add line numbers
         3) Added Cross-Referencing facility
            a) IMPORTANT!! Make sure when you create COM file you assign
               The minimum segment sizes given in a MEM compile
               (Particularly allow a minimum Stack Size Of 1300)
            b) The file 'TURBOPAS.RES' contains the reserved words for
               the TURBO Pascal compiler release 2.0.  If new reserved
               words are implemented in future releases, add the new
               words to this file.

            Please let me know if you run into any problems!
                   Michael Roberts  [CIS 74226,3045]
                   3103 Glenview
                   Royal Oak, MI 48073

*)

(* Supported pseudo operations:
    1) Listing control: {.L-} turns it off, {.L+} turns it back on,
       must be in column 1
    2. Page ejection: {.PAGE}, must be in column 1.
    *)

 { When program is first run will check for a file
   name passed by DOS, and will try to open that file.  If no name is
   passed, will ask operator for a file name to open.  Proc will tell
   operator if file doesn't exist and will allow multiple retrys.

   Included files will be expanded only if the program is invoked as
   follows:
     pretty filename /i
   The default is not to expand included files.

   On 2nd and later executions, proc will not check for DOS passed file
   name.  In all cases, proc will assume a file type of .PAS if file
   type is not specified.
   PROGRAM EXIT from this proc when a null string is encountered in
   response to a file name request. }
const monthmask = $000F;
  daymask = $001F;
  minutemask = $003F;
  secondmask = $001F;
  First   : boolean = true;    {true when prog is run}

{ to customize code for your printer - adjust the next item }

  maxline = 58;

  cr = #13;
  lf = #10;
  ff = #12;
type
   ResWordPtr = ^ResWordRec;
   ResWordRec = Record
                ResWord: String[20];
                Next   : ResWordPtr;
                end;
   XrefWordptr = ^XrefwordRec;
   XrefNumPtr  = ^XrefNumRec;
   XrefWordRec = Record
                 XrefWord: string[20];
                 FirstXrefNum: XrefNumPtr;
                 LastXrefNum : XrefNumPtr;
                 NextXrefWord: XrefwordPtr;
                 end;
   XrefNumRec  = record
                 XrefNum : Integer;
                 NextXrefNum:XrefNumPtr;
                 end;
   alfa = string[15];
   two_letters = string[2];
   dtstr = string[8];
   fnmtype = string[14];
   instring = string[135];
   regpack = record
      ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
   end;

Var
  answer    : char;
  Buff1     : instring;          {input line buffer}
  FirstResWord, LastResWord, NewResWord, SrchResWord: ResWordPtr;
  FirstxRefWord, NewxRefWord, PrevXrefWord, SrchxRefWord: XRefWordPtr;
  NewXRefnum, SrchXRefNum: XRefNumPtr;
  ResWord   : string[20];
  XrefWord  : string[20];
  XrefNum   : Integer;
  wordchk   : alfa;
  heaptop   : ^Integer;
  listfil   : text;              {FIB for LST: or CON: output}
  infile    : text;              {FIB for input file}
  initfile  : text;              {FIB for reserved word file}
  fnam      : fnmtype;           {in file name}
  bcount    : integer;           {begin/end counter}
  kcount    : integer;           {comment counter}
  linect    : integer;           {output file line counter}
  linecnt   : integer;
  pageno    : integer;
  offset    : integer;
  print     : boolean;           (* {.L-} don't print *)
                                 (* {.L+} print       *)
  print_head : boolean;
  Print_Xref : boolean;
  Word_switch: Boolean;
  c         : char;
  month, day, year,
  hour, minute, second : two_letters;
  sysdate, systime,
  filedate, filetime : dtstr;
  expand_includes    : boolean;
  holdarg            : instring;
  allregs : regpack;
{.page}

Function Find_in_Reserve(var kword: alfa) : boolean;
Begin
    SrchResWord := firstresword;
    while ((kword > srchresword^.resword) and (srchresword <> nil)) do
          srchresword := srchresword^.next;
    if srchresword = nil then
       Find_in_Reserve := FALSE
    else
        if kword = srchresword^.resword then
           Find_in_reserve := true
        else
            Find_in_reserve := False;
End;



PROCEDURE Initialize;
BEGIN
     assign(initfile,'TURBOPAS.RES');
     reset(initfile);
     FirstResWord := nil;
     while not eof(initfile) do
     begin
          readln(initfile,ResWord);
          if length(ResWord) <> 0 then
             begin
                  New(NewResWord);
                  NewResWord^.ResWord := Resword;
                  if FirstResWord = nil then
                     FirstResWord := NewResWord
                  else
                     LastResWord^.next := NewResWord;
                  LastResWord := NewResWord;
                  LastResWord^.Next := Nil;
             end;
     end;
END; {of Initialize}

procedure getchar(var char_value : char);
   begin
     allregs.ax := $0000;
     intr($16, allregs);
     char_value := chr(ord(lo(allregs.ax)));
   end; {getchar}

procedure fill_blanks (var line: dtstr);
  var
    i : integer;
begin
  for i:= 1 to 8 do if line[i] = ' ' then line[i]:= '0';
end;  {fill_blanks}

procedure getdate(var date : dtstr);

begin
   allregs.ax := $2A * 256;
   MsDos(allregs);
   str((allregs.dx div 256):2,month);
   str((allregs.dx mod 256):2,day);
   str((allregs.cx - 1900):2,year);
   date := month + '/' + day + '/' + year;
   fill_blanks (date);
end;  {getdate}

procedure gettime(var time : dtstr);

begin
   allregs.ax := $2C * 256;
   MsDos(allregs);
   str((allregs.cx div 256):2,hour);
   str((allregs.cx mod 256):2,minute);
   str((allregs.dx div 256):2,second);
   time := hour + ':' + minute + ':' + second;
   fill_blanks (time);
end;  {gettime}

procedure WhenCreated (var date, time: dtstr; var infile: text);

var fulltime,fulldate: integer;

begin

{fulldate gets the area of the FIB which corresponds to bytes 20-21
 of the FCB. Format is: bits 0 - 4: day of month
                             5 - 8: month of year
                             9 -15: year - 1980                     }

    fulldate:= memw [seg(infile):ofs(infile)+31];
    str(((fulldate shr 9) + 80):2,year);
    str(((fulldate shr 5) and monthmask):2,month);
    str((fulldate and daymask):2,day);
    date:= month + '/' + day + '/' + year;
    fill_blanks(date);

{fulltime gets the area of the FIB which corresponds to bytes 22-23
 of the FCB. Format is: bits 0 - 4: seconds/2
                             5 -10: minutes
                             11-15: hours                          }

    fulltime:= memw [seg(infile):ofs(infile)+33];
    str((fulltime shr 11):2,hour);
    str(((fulltime shr 5) and minutemask):2,minute);
    str(((fulltime and secondmask) * 2):2,second);
    time:= hour + ':' + minute + ':' + second;
    fill_blanks (time);
end;  {WhenCreated}

Procedure BuildXref;
Begin
     if ((FirstXrefWord = nil) or (FirstXrefWord^.XrefWord > wordchk)) then
        begin
             new(newxrefword);
             NewXrefWord^.NextXrefWord := FirstXrefWord;
             FirstXrefWord := NewXrefWord;
             FirstXrefWord^.XrefWord := wordchk;
             new(NewXrefNum);
             FirstXrefWord^.FirstXrefNum := NewXrefNum;
             FirstXrefWord^.LastXrefNum := NewXrefNum;
             NewXrefNum^.NextXrefNum := nil;
             NewXrefNum^.XrefNum := linecnt;
         end
     else
     begin
          If firstXrefWord^.xrefword = wordchk then
          begin
               New(NewXrefNum);
               FirstXrefWord^.LastXrefNum^.NextXrefNum := NewXrefNum;
               FirstXrefWord^.LastXrefNum := NewXrefnum;
               NewXrefNum^.NextXrefNum := Nil;
               NewXrefNum^.XrefNum := linecnt;
          end
          else
          Begin
               SrchXrefWord := FirstXrefword^.NextXrefWord;
               PrevXrefWord := FirstXrefWord;
               While ((SrchXrefWord <> Nil) and
               (SrchXrefWord^.XrefWord < WordChk)) do
               begin
                    PrevXrefWord := SrchXrefWord;
                    SrchXrefWord := SrchXrefWord^.NextXrefWord;
               end;
               If ((SrchXrefWord = nil) and
                  (PrevXrefWord^.XrefWord < wordchk)) then
                  Begin
                       new(newxrefword);
                       NewXrefWord^.NextXrefWord := Nil;
                       PrevXrefWord^.NextXrefWord := NewXrefWord;
                       NewXrefWord^.XrefWord := wordchk;
                       new(NewXrefNum);
                       NewXrefWord^.FirstXrefNum := NewXrefNum;
                       NewXrefWord^.LastXrefNum := NewXrefNum;
                       NewXrefNum^.NextXrefNum := nil;
                       NewXrefNum^.XrefNum := linecnt;
                  end
                  else
                      if SrchXrefWord^.XrefWord > Wordchk Then
                      Begin
                           new(newxrefword);
                           NewXrefWord^.NextXrefWord := SrchXrefWord;
                           PrevXrefWord^.NextXrefWord := NewXrefWord;
                           NewXrefWord^.XrefWord := wordchk;
                           NewXrefWord^.LastXrefNum := Nil;
                           new(NewXrefNum);
                           NewXrefWord^.FirstXrefNum := NewXrefNum;
                           NewXrefWord^.LastXrefNum := NewXrefNum;
                           NewXrefNum^.NextXrefNum := nil;
                           NewXrefNum^.XrefNum := linecnt;
                      end
                      else
                      begin
                           SrchXrefWord := SrchXrefWord^.NextXrefWord;
                           New(NewXrefNum);
                           SrchXrefWord^.LastXrefNum^.NextXrefNum := NewXrefNum;
                           SrchXrefWord^.LastXrefNum := NewXrefnum;
                           NewXrefNum^.NextXrefNum := Nil;
                           NewXrefNum^.XrefNum := linecnt;
                      end
          end;
     end;
end;

procedure print_heading(filename : fnmtype);

var offset_inc: integer;

begin
   if print then
     begin
       pageno := pageno + 1;
       write(listfil, ff);  {top of form}
       writeln(listfil);
       write(listfil,'     TURBO Pascal Program Lister');
       writeln(listfil,' ':8,'Printed: ',sysdate,'  ',
               systime,'   Page ',pageno:4);
       if filename <> fnam then begin
          offset_inc:= 14 - length (filename);
          write(listfil,'     Include File: ',filename,' ':offset_inc,
             'Created: ',filedate,'  ',filetime);
       end
       else write(listfil,'     Main File: ',fnam,' ':offset,
             'Created: ',filedate,'  ',filetime);
       writeln(listfil); writeln(listfil);
       If Print_Xref then
          Writeln(Listfil,' ':32,'CROSS-REFERENCE')
       else
           writeln(listfil, '      B');
       writeln(listfil);
       linect := 6;
     end; {check for print}
end;  {print_heading}

procedure printline(iptline : instring; filename : fnmtype);
begin
   if print then
     begin
       if linect < 56 then
         begin
          writeln(listfil,'     ',iptline);
          linect := linect + 1;
         end
          else
           begin
             print_heading(filename);
           end;
     end; {check for print}
end;  {printline}
{.page}
function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
var
   done : boolean;
   i, j : integer;
begin
   i := 4; j := 1; incflname := '';
   if copy(iptline, 1, 3) = '{$I' then begin
      i := 4; j := 1; incflname := '';
      while (iptline[i] = ' ') and (i <= length(iptline)) do i := i + 1;
      done := false;
      while not done do begin
         if i <= length(iptline) then begin
            if not (iptline[i] in [' ','}','+','-']) then begin
               incflname[j] := iptline[i];
               i := i + 1; j := j + 1;
            end else done := true;
         end else done := true;
         if j > 14 then done := true;
      end;
      incflname[0] := chr(j - 1);
   end;
   if incflname <> '' then
     begin
          chkinc := true;
          for i := 1 to length(Incflname) do
              incflname[i] := upcase(incflname[i]);
     end
     else
         chkinc := false;
end;  {chkinc}

function parse_cmd(argno : integer) : instring;
var
   i,j : integer;
   wkstr : instring;
   done : boolean;
   cmdline : ^instring;
begin
   cmdline := ptr(CSEG,$0080);
   wkstr := '';
   done := false; i := 1; j := 0;
   if length(cmdline^) < i then done := true;
   repeat
      while ((cmdline^[i] = ' ') and (not done)) do begin
         i := i + 1;
         if i > length(cmdline^) then done := true;
      end;
      if not done then j := j + 1;
      while ((cmdline^[i] <> ' ') and (not done)) do begin
         wkstr := wkstr + cmdline^[i];
         i := i + 1;
         if i > length(cmdline^) then done := true;
      end;
      if (j <> argno) then wkstr := '';
   until (done or (j = argno));
   for i := 1 to length(wkstr) do
      wkstr[i] := upcase(wkstr[i]); {all arguments forced to upper case}
   parse_cmd := wkstr;
end;

 PROCEDURE GET_IN_FILE;     {GETS INPUT FILE NAME }
   var
    existing : boolean;
    i        : integer;
  begin
    repeat             {until file exists}
      holdarg := parse_cmd(1); {get command line argument # 1}
      if (length(holdarg) in [1..14]) and first then
        fnam := holdarg  {move possible file name to fnam}
      else
        begin
          writeln;
          write(' ENTER FILE NAME TO LIST or <cr> to EXIT  ');
          readln(fnam);
          if fnam <> '' then
             begin
                  writeln;write(' EXPAND INCLUDES? (Y/N) ');
                  readln(answer);
                  if upcase(answer) = 'Y' then
                     expand_includes := true
                  else
                      expand_includes := false
             end
        end;

     for i := 1 to length(fnam) do
         fnam[i] := upcase(fnam[i]);

     if fnam = '' then HALT;         {***** EXIT *****}
     if pos('.',fnam) = 0 then       {file type given?}
       fnam := concat(fnam,'.PAS');  {file default to .PAS type}

     {get optional command line argument # 2}
     if (length(holdarg) in [1..14]) and first then
       begin
         holdarg := parse_cmd(2);
         if holdarg = '/I' then expand_includes := true
            else expand_includes := false;
       end;

     first := false;                 {get passed file name only once}
     assign( infile, fnam);
       {$I-}
     reset( infile );                {check for existence of file}
       {$I+}
     existing := (ioresult = 0);     {true if file found}
     if not existing then
       begin
        writeln;
        writeln(' FILE DOESN''T EXIST'); {tell operator the sad news}
       end;
    until existing;                     {until file exists}
 end; {GET_IN_FILE}

{ GET_OUT_FILE procedure asks operator to select output to console
  device or list device, and then assigns and resets a file control
  block to the appropriate device.  'C' or 'P' is only correct
  response, and multiple retrys are allowed. }

Procedure Get_Out_File;
  var
    c : char;
  begin
    repeat    {until good selection}
      writeln; write(' OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ?  ');
      getchar(c);
      c := upcase(c); write(c);
   until c in ['C', 'P'];

   writeln;
   if c = 'C' then
      assign (listfil, 'CON:')
   else
      assign (listfil, 'LST:');

   reset(listfil);
 end;  {GET_OUT_FILE}

Procedure ListIt(filename : fnmtype); forward;
{.page}
{ SCAN_LINE procedure scans one line of Turbo Pascal source code
  looking for BEGIN/END pairs, CASE/END pairs, LITERAL fields
  and COMMENT fields.  BCOUNT is begin/end and case/end counter.
  KCOUNT is comment counter.  Begin/case/ends are only valid
  outside of comment fields and literal constant fields (KCOUNT = 0
  and NOT LITERAL).
  Some of the code in the SCAN_LINE procedure appears at first glance
  to be repitive and/or redundant, but was added to speed up the
  process of scanning each line of source code.}

Procedure SCAN_LINE;
  var
    literal : boolean;          { true if in literal field}
    tmp     : string[7];        { tmp work area }
    i       : integer;          {loop variable index}
    buff2   : instring;         {working line buffer}
    incflname : fnmtype;        {in file name}
    filedate_save : dtstr;
    filetime_save : dtstr;
  begin
    literal := false;

    buff2[0] := buff1[0];  {copy input buffer to working buffer}
    for i := 1 to length(buff1) do
     buff2[i] := upcase(buff1[i]);  {and translate to upper case}

    if chkinc(buff2, incflname) and expand_includes then
       begin
       for i := 1 to length(incflname) do
           incflname[i] := upcase(incflname[i]);
          if pos('.',incflname) = 0 then incflname := incflname + '.PAS';
          printline('*************************************',incflname);
          printline('    Including "'+incflname+'"', incflname);
          printline('*************************************',incflname);
          filedate_save := filedate;  {save filedate & filetime for}
          filetime_save := filetime;  {main file                   }
          listit(incflname);
          filedate := filedate_save;  {restore}
          filetime := filetime_save;
          printline('*************************************',incflname);
          printline('    End of    "'+incflname+'"', incflname);
          printline('*************************************',incflname);
          linecnt := linecnt - 1;
         end;  {include file check}

    if copy(buff2,1,5) = '{.L-}' then
       begin
            print := false;
            if length(buff2) = 5 then
               linecnt := linecnt - 1;
       end;

    if copy(buff2,1,5) = '{.L+}' then
       begin
            print := true;
            if length(buff2) = 5 then
               linecnt := linecnt - 1;
       end;

    if copy(buff2,1,7) = '{.PAGE}' then
       begin
            print_head := true;
            if length(buff2) = 7 then
               linecnt := linecnt - 1;
       end;

    if length(buff2) > 0 then
       linecnt := linecnt + 1;

    buff2 := concat('  ', buff2, '      ');  {add on some working space}
    for i := 1 to length(buff2) - 6 do
      begin
        tmp := copy(buff2, i, 7);
        if not literal then   {possible to find comment delim}
          begin
           {determine if comment area delim}
           if tmp[1] in ['{', '}', '(', '*'] then
             begin
               if (tmp[1] = '{') or (copy(tmp,1,2)='(*') then
                 kcount := succ(kcount);  {count comment opens}
               if (tmp[1] = '}') or (copy(tmp,1,2)='*)') then
                 kcount := pred(kcount);  {un-count comment closes}
             end;
          end;

         if kcount = 0 then  {we aren't in a comment area}
           begin
            if tmp[1] = chr(39) then
              literal := not literal;   {toggle literal flag}
            if not literal then
            begin
              if ((not Word_switch) and
                 (buff2[i] in ['A'..'Z','a'..'z'])) then
                           Begin
                                Word_switch := true;
                                wordchk := '';
                           end;
              if word_switch then
                 if (buff2[i] in ['A'..'Z','a'..'z','0'..'9','_']) then
                    wordchk := concat(wordchk,upcase(Buff2[i]))
                 else
                 begin
                      word_switch := false;
                      if not find_in_reserve(wordchk) then
                         BuildXref;
                 end;
              end;
           if not literal and (tmp[2] in ['B','C','E']) then
             begin
               if (tmp = ' BEGIN ') or (copy(tmp,1,6) = ' CASE ') then
                begin
                 bcount := succ(bcount);  {count BEGIN}
                 i := i + 5;              {skip rest of begin}
                end;
               if (copy(tmp,1,4) = ' END') and
                  (tmp[5] in ['.', ' ', ';']) and
                   (bcount > 0) then
                begin
                 bcount := pred(bcount);   {un-count for END}
                 i := i + 4;
                end;

              end;  {if not literal}
           end;  { if kcount = 0 }
        end;  { for i := }
    end;  {SCAN_LINE}
{.page}
Procedure ListIt;
  var
    infile : text;
  begin
     assign(infile, filename);
   {$I-} reset(infile) {$I+} ;
   if IOresult <> 0 then begin
      writeln ('File ',filename,' not found.');
      halt;
   end;
     WhenCreated (filedate,filetime,infile);
         print_heading(filename);
         while not eof(infile) do
           begin
            readln(infile, buff1);
            scan_line;
            if print_head then
                print_heading(filename);
            if print and (not print_head) then
              begin
                if length(buff1) > 0 then
                   writeln(listfil,linecnt : 4, bcount : 3, ' ', buff1)
                else
                   writeln(listfil,'        ',buff1);
                linect := succ(linect);
                if linect > maxline then
                  begin
                    print_heading(filename);
                  end;
              end;
            print_head := false;
         end;     {while not eof}
  end; {ListIt}

Procedure ListXref;
Const
     blnk = ' ';
Var
   x, y: Integer;

Begin
     Print_Xref := True;
     Print_heading(fnam);
     Srchxrefword := Firstxrefword;
     while SrchXrefWord <> Nil Do
     Begin
          x := 20 - Length(SrchXrefWord^.XrefWord);
          for y := 1 to x do
              SrchXrefWord^.XrefWord := concat(SrchXrefWord^.XrefWord,blnk);
          Write(listfil,srchxrefword^.XrefWord);
          x := 0;
          SrchXrefNum := SrchXrefWord^.FirstXrefNum;
          while SrchXrefNum <> Nil do
          begin
               if X < 10 then
               begin
                    Write(listfil,SrchXrefNum^.XrefNum:5);
                    x := X + 1;
               end
               else
               begin
                    Writeln(listfil);
                    Linect := linect + 1;
                    if linect > maxline then Print_heading(fnam);
                    Write(listfil,blnk:20,SrchxrefNum^.XrefNum:5);
                    x := 0;
               end;
               SrchXrefNum := SrchXrefNum^.NextXrefNum;
          end;
          writeln(listfil);
          Linect := linect+1;
          if linect > Maxline then Print_heading(fnam);
          SrchXrefWord := SrchXrefWord^.NextXrefWord;
     end;
end;
{.page}
  begin {main procedure}
     getdate(sysdate);
     gettime(systime);
     expand_includes := false;       {default settings}
     print := true;
     initialize;
     Mark(heaptop);

   repeat {forever}
     Release(heaptop);
     FirstXrefWord := nil;
     ClrScr;
     GotoXY(2, 2);
     writeln('TURBO Pascal Formatted Listing');
     GotoXY(2, 4);
     get_in_file;      {file to list}
     offset := 24 - length(fnam);
     get_out_file;     {where to list it}
     pageno := 0;
     linect := 1;      {output line counter}
     kcount := 0;
     linecnt := 0;
     bcount := 0;
     print_head := false;
     Print_xref := False;
     word_switch:= False;
     listit(fnam);
     Listxref;
    write(cr, lf, 'HIT ANY KEY TO CONTINUE ');  {allow op to see end
                                                 of listing}
    getchar(c);
    until false {repeat forever - exit is in GET_IN_FILE PROCEDURE}
 end.  {main procedure}