Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB13.ZIP/CROSSREF.PAS

Pascal/Delphi Source File | 1985-07-14 | 17.2 KB | 602 lines

program TXREF;

{$V-}
{$R+}

{  Program TXREF - Produce a Listing and Cross Reference for a Turbo Pascal
   source file.

   You must have Turbo Toolbox from Borland International, Inc. in order to
   compile this program.

   As written, this program assumes that you have an Epson FX-80 printer. It
   may work on other printers if they are compatible enough.

   By Michael Quinlan
      Version 1.0.0
      12/1/84

  Known bugs:

    1. This program doesn't correctly handle certain types of constants;
       the 'E' in a floating point constant will be considered a name as
       will some hex constants. The procedure CopyTillAlpha needs to be
       re-written to handle these things better.

    2. Numeric labels are not included in the cross reference.

    3. Names longer than 79 bytes may mess up the page alignment while
       printing the cross reference.

}

const
  LinesPerPage = 60;

Type
  Str = String[127];
  XrefRec = record
              Name : Str;
              Page : Integer;
              Line : Integer;
            end;

var
  XrefVar       : XrefRec;
  NumOnLine     : Integer;
  CurLine       : Integer;
  CurPage       : Integer;
  SortResult    : Integer;
  InFileName    : Str;
  InFile        : Text;
  Line          : Str;
  CurPosn       : Integer;
  CommentStatus : (NoComment, CurlyBracket, ParenStar);
  InsideString  : Boolean;
  Summary       : Char;

const
 NumReservedWords = 44;
 BiggestReservedWord = 9;
 ReservedWordList : array [1..NumReservedWords] of String[BiggestReservedWord]
   = (
  'ABSOLUTE', 'AND'     , 'ARRAY' , 'BEGIN', 'CASE'    , 'CONST' , 'DIV',
  'DO'      , 'DOWNTO'  , 'ELSE'  , 'END'  , 'EXTERNAL', 'FILE'  , 'FOR',
  'FORWARD' , 'FUNCTION', 'GOTO'  , 'IF'   , 'IN'      , 'INLINE', 'LABEL',
  'MOD'     , 'NIL'     , 'NOT'   , 'OF'   , 'OR'      , 'PACKED', 'PROCEDURE',
  'PROGRAM' , 'RECORD'  , 'REPEAT', 'SET'  , 'SHL'     , 'SHR'   , 'STRING',
  'THEN'    , 'TO'      , 'TYPE'  , 'UNTIL', 'VAR'     , 'WHILE' , 'WITH',
  'XOR'     , 'OVERLAY');

VAR  TDate : String[8];  {Global variable for DOSDate}

PROCEDURE DOSDate;
  TYPE
    regpack = record
                ax,bx,cx,dx,bp,si,ds,es,flags: integer;
              end;
  VAR
    recpack:       regpack;                {record for MsDos call}
    month,day:     string[2];
    year:          string[4];
    dx,cx:         integer;
  begin
    with recpack do
    begin
      ax := $2a shl 8;
    end;
    MsDos(recpack);                        { call function }
    with recpack do
    begin
      str(cx,year);                        {convert to string}
      str(dx mod 256,day);                     { " }
      str(dx shr 8,month);                     { " }
    end;
    Year:=Copy(Year,3,2);
    If Length(Month) = 1 then Month:='0'+Month;
    If Length(Day) = 1 then Day:='0'+Day;
    Tdate := month + '/' + day + '/' + year;
  end;

var
  ReservedWordHashTable : array [1..NumReservedWords] of
                            record
                              WordPtr : Integer;
                              NextPtr : Integer
                            end;

 {$I A:SORT.BOX}  { Include the sort routines from Turbo ToolBox }

{=======================================================================}
{  Printer Routines                                                     }
{=======================================================================}

procedure Printer_Init;
{ Init the printer to 132 column mode }
begin
  Write(Lst,#27'Q'#27'L020')
end;

procedure Printer_Reset;
{ reset printer back to 80 column mode }
begin
  Write(Lst,#27'Q'#27'L020')  { turn compressed mode off }
end;

procedure Printer_Underscore;
{ Turn on underlines }
begin
  Write(Lst, #27'X')  { turn on underlines }
end;

procedure Printer_NoUnderscore;
{ Turn off underlines }
begin
  Write(Lst, #27'Y')  { turn off underlines }
end;

procedure Printer_Eject;
{ Eject to a new page }
Var I:Integer;
begin
  If CurLine <60 then For I:=CurLine to 60 do WriteLn(Lst);
  WriteLn(Lst);
  Writeln(Lst,'Listing of ':90, InFileName, ', Page ':5, CurPage);
  Write(Lst, #12)
end;

{======================================================================}
{ Procedures for handling the hash table; this is used to speed up     }
{ checking for reserved words.                                         }
{======================================================================}

function ReservedWordHash(var w : Str) : Integer;
var
  c : char;
  h : integer;
  i : integer;
  n : integer;
begin
  h := 0;
  n := 1;
  for i := 1 to (length(w) div 2) do
    begin
      h := h xor ((Ord(w[n]) shl 8) or Ord(w[n+1]));
      n := n + 2
    end;
  if n = length(w) then
    h := h xor Ord(w[n]);
  ReservedWordHash := ((h and $7FFF) mod NumReservedWords) + 1
end;

procedure SetUpReservedWordHashTable;
var
  h : integer;
  i : integer;
  NewH : integer;
  MinProbes, MaxProbes, NumProbes, TotProbes : integer;  { for debugging only }
  AvgProbes : Real;  { for debugging only }

  function FindFreeEntry(h : integer) : integer;
  begin
    repeat
      if h >= NumReservedWords then h := 1
      else h := h + 1
    until ReservedWordHashTable[h].WordPtr = 0;
    FindFreeEntry := h
  end;

begin
  for i := 1 to NumReservedWords do
    begin
      ReservedWordHashTable[i].WordPtr := 0;
      ReservedWordHashTable[i].NextPtr := 0
    end;
  for i := 1 to NumReservedWords do
    begin
      h := ReservedWordHash(ReservedWordList[i]);
      if ReservedWordHashTable[h].WordPtr = 0 then
        ReservedWordHashTable[h].WordPtr := i
      else
        begin { handle collisions }
          { first find the end of the chain }
          while ReservedWordHashTable[h].NextPtr <> 0 do
            h := ReservedWordHashTable[h].NextPtr;
          { now attach the new entry onto the end of the chain }
          NewH := FindFreeEntry(h);
          ReservedWordHashTable[h].NextPtr := Newh;
          ReservedWordHashTable[NewH].WordPtr := i
        end
    end;

{ the following is for debugging only }
  (***********************************************************************

     D E B U G G I N G   C O D E   C O M M E N T E D   O U T

   ***********************************************************************

  { calculate the min, max, and average number of probes required into the
    hash table }
  TotProbes := 0;
  MinProbes := MaxInt;
  MaxProbes := 0;
  for i := 1 to NumReservedWords do
    begin
      h := ReservedWordHash(ReservedWordList[i]);
      NumProbes := 1;
      while ReservedWordHashTable[h].WordPtr <> i do
        begin
          NumProbes := NumProbes + 1;
          h := ReservedWordHashTable[h].NextPtr
        end;
      TotProbes := TotProbes + NumProbes;
      if NumProbes > MaxProbes then MaxProbes := NumProbes;
      if NumProbes < MinProbes then MinProbes := NumProbes
    end;
  AvgProbes := TotProbes / NumReservedWords;
  writeln('RESERVED WORD HASH TABLE STATISTICS');
  writeln(' Max Probes = ', MaxProbes);
  writeln(' Min Probes = ', MinProbes);
  writeln(' Avg Probes = ', AvgProbes:8:2)

*************************************************************************)

end;

{======================================================================}
{  Procedures to set up the input file.                                }
{======================================================================}

procedure UpStr(var s : Str);
var
  i : integer;
begin
  for i := 1 to length(s) do s[i] := UpCase(s[i])
end;

function GetParm : Str;
var
  Parm : Str absolute CSeg:$80;
begin
  GetParm := Parm
end;

function AskFileName : Str;
var
  f : Str;
begin
  Write('Name of file to cross reference: ');
  Readln(f);
  if f = '' then halt;  { provide an exit for the user }
  AskFileName := f
end;

function OpenInFile : boolean;
begin
  UpStr(InFileName);  { convert file name to upper case }
  if Pos('.', InFileName) = 0 then InFileName := InFileName + '.PAS';
  Assign(InFile, InFileName);
  {$I-} Reset(InFile); {$I+}
  OpenInFile := (IOResult = 0)
end;

procedure GetInFile;
begin
{ on entry, InFileName may already have the file name }
  if InFileName = '' then InFileName := AskFileName;
  while not OpenInFile do
    begin
      Writeln('Cannot open ', InFileName);
      InFileName := AskFileName
    end
end;

procedure NewPage;
begin
  if CurPage = 0 then
    begin
      Writeln('Make sure printer is lined up at the top of the page and powered on.');
      Write('Press Enter when ready... ');
      readln;
      Printer_Init  { set printer in 132 column mode }
    end
  else
    Printer_Eject;
  CurPage := CurPage + 1;
  CurLine := 1;
  Writeln(Lst,'Listing of ':80, InFileName, ' on ', TDate, ', Page ':5, CurPage);
  Writeln(Lst)
end;

procedure ReadLine;
begin
  Readln(InFile, Line);
  if CurLine >= LinesPerPage then NewPage
  else CurLine := CurLine + 1;
  CurPosn := 1;
  InsideString := FALSE;
  Write(Lst, CurLine:2, ':   ')
end;

{======================================================================}
{  Procedures to process the input file.                               }
{======================================================================}

procedure CopyTillAlpha;
{ copy chars from Line to the printer until the start of a name is found }
begin
  while (CurPosn <= length(Line)) and
         (not (Line[CurPosn] in ['A'..'Z','a'..'z','_']) or InsideString or
          (CommentStatus <> NoComment)) do
    begin
      if CommentStatus = NoComment then
        begin
          if Line[CurPosn] = '''' then InsideString := not InsideString
        end;
      if not InsideString then
        case CommentStatus of
          NoComment : begin
                        if Line[CurPosn] = '{' then CommentStatus := CurlyBracket
                        else if CurPosn < length(Line) then
                               begin
                                 if Copy(Line, CurPosn, 2) = '(*' then
                                   CommentStatus := ParenStar
                               end
                      end;
          CurlyBracket : if Line[CurPosn] = '}' then CommentStatus := NoComment;
          ParenStar    : if CurPosn < length(Line) then
                           begin
                             if Copy(Line, CurPosn, 2) = '*)' then
                               CommentStatus := NoComment
                           end
        end; { Case }
      Write(Lst, Line[CurPosn]);
      CurPosn := CurPosn + 1
    end
end;

function Reserved(var w : Str) : boolean;
var
  h : integer;
  r : (DontKnow, IsReserved, NotReserved);
begin
  h := ReservedWordHash(w);
  r := DontKnow;
  repeat
    if w = ReservedWordList[ReservedWordHashTable[h].WordPtr] then
      r := IsReserved
    else if ReservedWordHashTable[h].NextPtr = 0 then
      r := NotReserved
    else h := ReservedWordHashTable[h].NextPtr
  until r <> DontKnow;
  Reserved := (r = IsReserved)
end;

procedure WriteReserved(var w : Str);
begin
  Printer_Underscore;  { turn on underscores }
  write(Lst, w);
  Printer_NoUnderscore { turn off underscores }
end;

procedure WriteWord(var Word, CapWord : Str);
begin
  XrefVar.Name := CapWord;
  XrefVar.Page := CurPage;
  XrefVar.Line := CurLine;
  SortRelease(XrefVar);
  write(Lst, Word)
end;

procedure DoWord;
var
  wstart  : integer;
  Word    : Str;
  CapWord : Str;
  ResWord : Str;
begin
  wstart := CurPosn;
  repeat
    CurPosn := CurPosn + 1
  until (CurPosn > length(Line)) or not (Line[CurPosn] in ['A'..'Z','a'..'z','_','0'..'9']);
  Word := Copy(Line, wstart, CurPosn - wstart);
  CapWord := Word;
  UpStr(CapWord);  { Upper case version of the word }
  if Reserved(CapWord) then begin
    ResWord := CapWord;
    WriteReserved(Word);
  end else begin
    WriteWord(Word, CapWord);
    If (ResWord='PROCEDURE') or (ResWord='FUNCTION') then begin
      CapWord:=ResWord + ' ' + Word;
      Word := '';
      WriteWord(Word, CapWord);
    End;
  End;
end;

procedure Inp;
begin
  GetInFile;
  CurLine := 1000;  { force page break on first line }
  CurPage := 0;
  CommentStatus := NoComment;
  while not EOF(InFile) do
    begin
      ReadLine;
      while CurPosn <= length(Line) do
        begin
          CopyTillAlpha;
          if CurPosn <= length(Line) then DoWord
        end;
      Writeln(Lst)
    end
end;

{======================================================================}
{  Procedure called by TurboSort to order the cross reference entries  }
{======================================================================}

function Less;
var
  FirstRec  : XrefRec absolute X;
  SecondRec : XrefRec absolute Y;
begin
  if FirstRec.Name = SecondRec.Name then
    begin
      if FirstRec.Page = SecondRec.Page then
        Less := FirstRec.Line < SecondRec.Line
      else
        Less := FirstRec.Page < SecondRec.Page
    end
  else
    Less := FirstRec.Name < SecondRec.Name
end;

{======================================================================}
{  Procedures to print the sorted cross reference                      }
{======================================================================}

procedure Xref_NewPage;
begin
  Printer_Eject;
  Writeln(Lst);
  Writeln(Lst);
  Writeln(Lst, 'C R O S S   R E F E R E N C E':54);
  Writeln(Lst, 'Entries are PAGE:LINE':50);
  Writeln(Lst);
  CurLine := 5;
  CurPage := CurPage+1;
end;

procedure Xref_NewLine;
begin
  Writeln(Lst);
  if CurLine >= LinesPerPage then Xref_NewPage
  else CurLine := CurLine + 1;
  NumOnLine := 0
end;

procedure Xref_Write_Number(n, count : integer);
{ write "n" to Lst with "count" digits (add leading zeros) }
var
  s : Str;
  i : integer;
begin
  for i := count downto 1 do
    begin
      s[i] := Chr((n mod 10) + Ord('0'));
      n := n div 10
    end;
  s[0] := Chr(count);  { set correct string length }
  write(Lst, s)
end;

procedure Xref_Write;
begin
  if NumOnLine >= 8 then Xref_NewLine;
  if NumOnLine = 0 then Write(Lst, '   ');
  Write(Lst, ' ');
  Xref_Write_Number(XrefVar.Page, 5);
  Write(Lst, ':');
  Xref_Write_Number(XrefVar.Line, 2);
  NumOnLine := NumOnLine + 1
end;

procedure Xref_NewName;
begin
  if (CurLine + 2) >= LinesPerPage then Xref_NewPage;
  Printer_Underscore;  { turn on underscores }
  Write(Lst, XrefVar.Name);
  Printer_NoUnderscore; { turn off underscores }
  Xref_NewLine
end;

procedure Outp;
var
  CurName : Str;
begin
  Printer_Reset;  { put printer back into 80 column mode }
  Xref_NewPage;
  SortReturn(XrefVar);
  CurName := XrefVar.Name;
  If (Summary = 'B') or
         (Summary = 'C') and NOT (Copy(XrefVar.Name,1,9) = 'PROCEDURE') or
         (Summary = 'C') and NOT (Copy(XrefVar.Name,1,8) = 'FUNCTION') or
         (Summary = 'L') and (Copy(XrefVar.Name,1,9) = 'PROCEDURE') or
         (Summary = 'L') and (Copy(XrefVar.Name,1,8) = 'FUNCTION') then begin
    Xref_NewName;
    Xref_Write;
  End;
  while not SortEOS do
    begin
      SortReturn(XrefVar);
      If (Summary = 'B') or
         (Summary = 'C') and NOT (Copy(XrefVar.Name,1,9) = 'PROCEDURE') or
         (Summary = 'C') and NOT (Copy(XrefVar.Name,1,8) = 'FUNCTION') or
         (Summary = 'L') and (Copy(XrefVar.Name,1,9) = 'PROCEDURE') or
         (Summary = 'L') and (Copy(XrefVar.Name,1,8) = 'FUNCTION') then begin
           if CurName <> XrefVar.Name then
             begin
               Xref_NewLine;
               CurName := XrefVar.Name;
               Xref_NewName
             end;
           Xref_Write
      End;
    end;
  Writeln(Lst);
  CurLine := CurLine +2;
  Printer_Eject
end;

{======================================================================}
{  Main Program                                                        }
{======================================================================}

begin
  ClrScr;
  Printer_Init;
  DOSDate;
  Write('Pascal Source Listing and Cross Reference Program V1.0.0');
  Writeln('  By Michael Quinlan');
  Writeln;
  SetUpReservedWordHashTable;
  InFileName := GetParm;
  while (length(InFileName)>0) and (InFileName[1] = ' ') do
    delete(InFileName, 1, 1);
  WriteLn;
  WriteLn('[C]omplete Summary WITHOUT Procedures and Functions or...');
  WriteLn('[L]ist Procedures and Functions ONLY or...');
  Write('[B]oth ');
  Repeat
    GotoXY(WhereX,WhereY);
    Repeat until KeyPressed;
    Read(Kbd,Summary);
    Summary := Upcase(Summary);
    Write(Summary);
    If NOT (Summary in ['C','L','B']) then Write(^G);
  Until Summary in ['C','L','B'];
  WriteLn;
  WriteLn;
  SortResult := TurboSort(SizeOf(XrefRec));
  writeln;
  case SortResult of
     0 : Writeln('Program Completed OK');
     3 : Writeln('Insufficient Memory for Sort');
     8 : Writeln('Illegal Item Length for Sort (Program Logic Error)');
     9 : Writeln('More Than ', MaxInt, ' Items to be Sorted');
    10 : Writeln('Sort Error, Disk Error or Disk Full?');
    11 : Writeln('Write Error During Sort, Bad Disk?');
    12 : Writeln('File Creation Error During Sort')
  else
    Writeln('Unknown Error ', SortResult, ' From Sort')
  end; { Case }
  if SortResult <> 0 then
    Writeln('*** Sort Failed; Cross Reference Invalid or Incomplete')
end.