program Map;

{ Version 1.7 -- Fixed bug with detection of FORWARD declared routines
          1.6 -- Fixed the detection of overlayed, string-returning, functions under DOS
                 Fixed problem with include directives "hidden" within a comment section
                 Added logic for paged output to the console
                 Added ability to sort output by size or name within overlay group
          1.5 -- Modified the include filename parsing logic
          1.4 -- Modified to put version and machine specific information into an include file
                 Also simplified the stategy to not try looking ahead if overlays end on a sector boundary
          1.3 -- Allows for re-trying an overlay group for different
                 combinations of handling an ambiguous end of overlay
                 situation. }

const RevisionDate = 'May 1986';
      RevisionNumber = '1.7';

      MaxRoutinesInGroup = 100;                  { Maximum number of routines allowed in any one overlay group }

type BinaryFile = file;
     ChrStr = string[127];
     TextFile = text;
     Word = string[127];

{$I MAPDOS.PAS }   { <----------  Change this include to configure for various machine configurations }

var CurrentWord: Word;
    FileName: ChrStr;
    I: integer;
    IncludeFile: TextFile;
    IncludeFlag: boolean;
    InputFile: TextFile;
    LastChar: char;
    LineCount: integer;
    MainFileName: ChrStr;
    OutputFile: TextFile;
    OutputFileName: ChrStr;
    OverlayGroupNumber: integer;
    OverlayGroupSize: array[0..99] of integer;
    PageLength: integer;
    PageMargin: integer;
    ReUseNextWord: boolean;
    SortMode: integer;

procedure ScanForOverlayGroup; forward;

procedure Terminate(ErrorString: ChrStr);
  { Output an error message and halt }
  begin
  writeln;
  writeln(ErrorString);
  halt
  end;

procedure BumpLineCount;
  { Increment the line count and display every 16 lines to emulate the compiler }
  begin
  LineCount := succ(LineCount);
  if (LineCount and $000F)=0 then                { Faster than (LineCount mod 16)=0 }
    if IncludeFlag
     then
      write(^M'I ',LineCount)
     else
      write(^M'  ',LineCount)
  end;

function CompareWord(var Master: Word;Template: Word): boolean;
  { Return true if template matches the Master (case is ignored) }
  var Equal: boolean;
      I: integer;
  begin
  if length(Master)<>length(Template)
   then
    CompareWord := false
   else
    begin
    Equal := true;
    I := 1;
    while Equal and (I<=length(Master)) do
      begin
      Equal := upcase(Master[I])=Template[I];
      I := succ(I)
      end;
    CompareWord := Equal
    end
  end;

function OverlayFileName(OverlayNumber: integer): ChrStr;
  { Return the name of the overlay for the given overlay group }
  var Extension: string[3];
  begin
  str(OverlayNumber,Extension);
  Extension := copy('00'+Extension,length(Extension),3);
  OverlayFileName := copy(MainFileName,1,pos('.',MainFileName))+Extension
  end;

function TempFileName(OverlayNumber: integer): ChrStr;
  { Return the name of the temporary file for the given overlay group }
  var Extension: string[3];
  begin
  str(OverlayNumber,Extension);
  Extension := copy('0'+Extension,length(Extension),2);
  TempFileName := copy(MainFileName,1,pos('.',MainFileName))+'$'+Extension
  end;

function GetNextWord(var NextWord: Word): boolean;
  { Return next word from input file and set result false on EOF }
  var EndOfWord: boolean;
      InputState: (Normal,BraceComment,BraceDirective,ParenComment,ParenDirective,StringConstant);
      NextChar: char;

  procedure HandleIncludeDirective;
    { Redirect input because of an include directive }
    const ValidFileChars: set of char = ['A'..'Z','a'..'z','0'..'9','.','\'];
    var I: integer;
    begin
    if not IncludeFlag then
      begin
      if seekeoln(InputFile) then ;              { Skip any leading spaces }
      BumpLineCount;                             { So we don't lose the carriage return }
      readln(InputFile,FileName);
      if not (FileName[1] in ['+','-']) then     { Skip I/O error checking directives }
        begin
        I := 0;
        while FileName[succ(I)] in ValidFileChars do
          I := succ(I);                          { Keep only valid filename characters }
        FileName := copy(FileName,1,I);
        if pos('.',FileName)=0 then
          FileName := FileName+'.PAS';           { Default extension to .PAS }
        assign(IncludeFile,FileName);
        {$I-}
        reset(IncludeFile);
        {$I+}
        if ioresult<>0 then
          Terminate(^G'Include file ('+FileName+') not found.');
        EndOfWord := true;
        IncludeFlag := true
        end
      end
    end;

  begin
  GetNextWord := true;
  if ReUseNextWord
   then
    ReUseNextWord := false
   else
    begin
    NextWord := '';
    repeat
      EndOfWord := false;
      InputState := Normal;
      repeat
        if IncludeFlag
         then
          if eof(IncludeFile)
           then
            begin
            EndOfWord := true;
            IncludeFlag := false;
            close(IncludeFile)
            end
           else
            read(IncludeFile,NextChar)
         else
          if eof(InputFile)
           then
            begin
            EndOfWord := true;
            GetNextWord := false
            end
           else
            read(InputFile,NextChar);
        if NextChar=#13 then                     { Count the number of lines processed so far }
          BumpLineCount;
        if not EndOfWord then
          case InputState of
            Normal: case NextChar of
                      '{': InputState := BraceDirective;
                      '*': if LastChar='(' then
                             InputState := ParenDirective;
                      '''': InputState := StringConstant;
                      'a'..'z','A'..'Z','_','0'..'9': NextWord := NextWord+NextChar
                      else EndOfWord := NextWord<>''
                      end;
            BraceComment: EndOfWord := NextChar='}';  { Wait for the trailing comment mark }
            BraceDirective: begin
                            EndOfWord := NextChar='}';  { In case of a pair of braces adjacent }
                            if not EndOfWord and (LastChar+NextChar <> '{$') then
                              begin
                              if LastChar+NextChar = '$I' then
                                HandleIncludeDirective;
                              InputState := BraceComment  { An include directive no longer possible }
                              end
                            end;
            ParenComment: EndOfWord := LastChar+NextChar='*)';  { Wait for the trailing comment mark }
            ParenDirective: if LastChar+NextChar <> '*$' then
                              begin
                              if LastChar+NextChar = '$I' then
                                HandleIncludeDirective;
                              InputState := ParenComment  { An include directive no longer possible }
                              end;
            StringConstant: if NextChar='''' then
                              EndOfWord := true
            end;
        LastChar := NextChar
      until EndOfWord
    until (NextWord<>'') or eof(InputFile)
    end
  end;

procedure RetryOverlayGroup(CurrentOverlayNumber: integer;var OverlayFyle: BinaryFile;var DescriptionFyle: TextFile);
  { If the first try at analyzing the overlay group didn't work, then we'll try
    again and handle the ambiguous end of overlay detection differently until
    we get a pattern which works }
  var AmbiguousCount: integer;
      BufferIndex: integer;
      ErrorDetected: boolean;
      NewDescriptionFyle: TextFile;
      RetryCount: integer;
      RoutineType: char;
      RoutineName: Word;
      SizeInBytes: integer;
  begin
  writeln;
  RetryCount := 1;                               { Use this integer as a binary pattern }
  repeat
    writeln('Retry number ',RetryCount,' on overlay group ',CurrentOverlayNumber,'.');
    reset(OverlayFyle);
    reset(DescriptionFyle);
    assign(NewDescriptionFyle,copy(MainFileName,1,pos('.',MainFileName))+'$$$');
    rewrite(NewDescriptionFyle);
    OverlayGroupSize[CurrentOverlayNumber] := 0;
    AmbiguousCount := 0;
    ErrorDetected := false;
    while not eof(DescriptionFyle) and not ErrorDetected do
      begin
      readln(DescriptionFyle,RoutineType,SizeInBytes,RoutineName);

      SizeInBytes := -QuantizationSize;
      repeat
        SizeInBytes := SizeInBytes+QuantizationSize;
        {$I-}
        blockread(OverlayFyle,Buffer,QuantizationSize div 128);
        {$I+}
        ErrorDetected := ioresult<>0             { Underflow in the overlay file }
      until EndOfOverlay(OverlayFyle,BufferIndex,AmbiguousCount,RetryCount) or ErrorDetected;
      SizeInBytes := SizeInBytes+BufferIndex;    { BufferIndex is the number of code bytes in last record of overlay }
      if OverlayGroupSize[CurrentOverlayNumber]*QuantizationSize < SizeInBytes then
        OverlayGroupSize[CurrentOverlayNumber] := (SizeInBytes+QuantizationSize-1) div QuantizationSize;

      writeln(NewDescriptionFyle,RoutineType,' ',SizeInBytes,' ',RoutineName)
      end;
    ErrorDetected := not eof(OverlayFyle);
    close(OverlayFyle);
    close(DescriptionFyle);
    close(NewDescriptionFyle);
    RetryCount := succ(RetryCount)
  until not ErrorDetected or (RetryCount>=round(exp(ln(2.0)*AmbiguousCount)));
  if not ErrorDetected
   then
    begin
    erase(DescriptionFyle);
    rename(NewDescriptionFyle,TempFileName(CurrentOverlayNumber))
    end
   else
    Terminate(^G'Overlay file cannot be analyzed.')
  end;

{$A-}
procedure ScanForEnd;
  { Scan the source code looking for the matching END for the current keyword }
  var NotMatchingRecord: boolean;
  begin
  NotMatchingRecord := not CompareWord(CurrentWord,'RECORD');
  while GetNextWord(CurrentWord) do
    if CompareWord(CurrentWord,'END')
     then
      exit
     else
      if CompareWord(CurrentWord,'BEGIN') or CompareWord(CurrentWord,'RECORD') or
         (NotMatchingRecord and CompareWord(CurrentWord,'CASE')) then
        ScanForEnd
  end;

procedure ScanForRoutine;
  { Scan the source code looking for the end the current routine (procedure or function) }
  begin
  while GetNextWord(CurrentWord) do
    if CompareWord(CurrentWord,'BEGIN')
     then
      begin
      ScanForEnd;
      exit
      end
     else
      if CompareWord(CurrentWord,'FORWARD')
       then
        exit                                     { Once you see the FORWARD, you're done }
       else
        if CompareWord(CurrentWord,'RECORD') or CompareWord(CurrentWord,'CASE')
         then
          ScanForEnd
         else
          if CompareWord(CurrentWord,'PROCEDURE') or CompareWord(CurrentWord,'FUNCTION')
           then
            ScanForRoutine
           else
            if CompareWord(CurrentWord,'OVERLAY') then
              ScanForOverlayGroup
  end;

procedure ScanForOverlay(CurrentOverlayNumber: integer;var Fyle: BinaryFile;var TempFyle: TextFile);
  { Scan for the end of the current overlay routine (procedure or function) }
  var AmbiguousCount: integer;
      BufferIndex: integer;
      SizeInBytes: integer;
  begin
  AmbiguousCount := 0;
  if GetNextWord(CurrentWord) then ;             { Get the following PROCEDURE or FUNCTION }
  write(TempFyle,upcase(CurrentWord[1]),' ');
  if GetNextWord(CurrentWord) then ;             { Get name of procedure or function }

  SizeInBytes := -QuantizationSize;
  repeat
    SizeInBytes := SizeInBytes+QuantizationSize;
    {$I-}
    blockread(Fyle,Buffer,QuantizationSize div 128);
    {$I+}
    if ioresult<>0 then                          { The data in the overlay file has fooled us }
      Terminate(^G'Overlay file cannot be analyzed (underflow).')
  until EndOfOverlay(Fyle,BufferIndex,AmbiguousCount,0);
  SizeInBytes := SizeInBytes+BufferIndex;        { BufferIndex is the number of code bytes in last record of overlay }
  writeln(TempFyle,SizeInBytes,' ',CurrentWord);
  if OverlayGroupSize[CurrentOverlayNumber]*QuantizationSize < SizeInBytes then
    OverlayGroupSize[CurrentOverlayNumber] := (SizeInBytes+QuantizationSize-1) div QuantizationSize;

  ScanForRoutine
  end;

procedure ScanForOG(CurrentOverlayNumber: integer);
  { Scan for the end of the current overlay group }
  var ErrorDetected: boolean;
      Fyle: BinaryFile;
      TempFyle: TextFile;
  begin
  assign(Fyle,OverlayFileName(CurrentOverlayNumber));
  {$I-}
  reset(Fyle);
  {$I+}
  if ioresult<>0 then
    Terminate(^G'Overlay file not found.');

  assign(TempFyle,TempFileName(CurrentOverlayNumber));
  {$I-}
  rewrite(TempFyle);
  {$I+}
  if ioresult<>0 then
    Terminate(^G'Directory full.');

  ScanForOverlay(CurrentOverlayNumber,Fyle,TempFyle);
  while GetNextWord(CurrentWord) do
    if CompareWord(CurrentWord,'OVERLAY')
     then
      ScanForOverlay(CurrentOverlayNumber,Fyle,TempFyle)
     else
      begin
      ReUseNextWord := true;
      ErrorDetected := not eof(Fyle);
      close(Fyle);
      close(TempFyle);
      if ErrorDetected then
        RetryOverlayGroup(CurrentOverlayNumber,Fyle,TempFyle);
      exit
      end
  end;
{$A+}

procedure ScanForOverlayGroup;                   { Note the FORWARD declaration above }
  { Call the recursive routine to find the end of the current overlay group }
  begin
  OverlayGroupNumber := succ(OverlayGroupNumber);
  ScanForOG(OverlayGroupNumber)
  end;

procedure EnterParameters;
  { Get the filenames and page layout values either from the command line or by prompting }
  var Ch: char;
      ErrorCode: integer;
  begin
  if paramcount>=1
   then
    MainFileName := paramstr(1)
   else
    repeat
      write('Enter name of source code file:');
      readln(MainFileName)
    until MainFileName<>'';
  MainFileName := MainFileName+'.PAS';
  assign(InputFile,MainFileName);
  {$I-}
  reset(InputFile);
  {$I+}
  if ioresult<>0 then
    Terminate(^G'File not found.');

  if paramcount>=2
   then
    OutputFileName := paramstr(2)
   else
    begin
    write('Enter name of result file (default is the console):');
    readln(OutputFileName);
    for ErrorCode := 1 to length(OutputFileName) do
      OutputFileName[ErrorCode] := upcase(OutputFileName[ErrorCode]);
    if OutputFileName='' then
      OutputFileName := 'CON:'
    end;
  assign(OutputFile,OutputFileName);
  {$I-}
  rewrite(OutputFile);
  {$I+}
  if ioresult<>0 then
    Terminate(^G'Directory full.');


  if paramcount>=3
   then
    Ch := upcase(copy(paramstr(3),1,1))
   else
    if paramcount>=1
     then
      Ch := 'N'                                  { Default to no sort not mentioned on command line }
     else
      begin
      write('Sort the output (Y/N)? ');
      repeat
        read(kbd,Ch);
        Ch := upcase(Ch)
      until Ch in ['Y','N'];
      writeln(Ch);
      if Ch='Y' then
        begin
        write('  Sort Alphabetically or by Size (A/S)? ');
        repeat
          read(kbd,Ch);
          Ch := upcase(Ch)
        until Ch in ['A','S'];
        writeln(Ch)
        end
      end;
  if Ch='A'                                      { Sort mode character - (N)o sort, sort by (S)ize, sort (A)lphabetically) }
   then
    SortMode := 1
   else
    if Ch='S'
     then
      SortMode := 2
     else
      SortMode := 0;                             { Default to no sorting }

  if OutputFileName='CON:'
   then
    PageLength := 24                             { Default for 24 or 25 line displays }
   else
    PageLength := 66;                            { Default page length }
  if paramcount>=4 then
    begin
    val(paramstr(4),PageLength,ErrorCode);
    if (ErrorCode<>0) or (PageLength<8) then
      Terminate(^G'Invalid page length.')
    end;

  if OutputFileName='CON:'
   then
    PageMargin := 1                              { Default for 24 or 25 line displays }
   else
    PageMargin := 6;                             { Default margin setting }
  if paramcount>=5 then
    begin
    val(paramstr(5),PageMargin,ErrorCode);
    if (ErrorCode<>0) or (PageLength < 2*PageMargin+6) or (PageMargin<1) then
      Terminate(^G'Invalid margin setting.')
    end;
  writeln
  end;

procedure OutputDataCollected;
  { Display the data }
  type DataType = record
         Name: Word;
         Size: integer;
         ProcFunc: char
         end;
  var Ch: char;
      Data: array[1..MaxRoutinesInGroup] of DataType;
      I: integer;
      J: integer;
      LineNumber: integer;
      RoutineNum: integer;

  function LessThan(var A,B: DataType): boolean;
    { Return true iff A < B for DataType }
    begin
    if SortMode = 1
     then
      LessThan := A.Name < B.Name
     else
      LessThan := A.Size > B.Size
    end;

  {$A-}
  procedure QuickSort(First,Last: integer);
    { A simple quicksort routine to sort the output information }
    { Thanks to Ira Polans 74065,403 for the algorithm }
    var Upper, Lower: integer;
        Pivot: DataType;

    procedure Exchange(var A,B: DataType);
      { Exchange the array elements }
      var Temp: DataType;
      begin
      Temp := A;
      A := B;
      B := Temp
      end;

    begin
    if First < Last then
      begin
      Upper := First;
      Lower := Last;
      Pivot := Data[Last];
      repeat
        while LessThan(Data[Upper],Pivot) do
          Upper := succ(Upper);
        while not LessThan(Data[Lower],Pivot) and (Lower > Upper) do
          Lower := pred(Lower);
        if Upper < Lower then
          Exchange(Data[Upper],Data[Lower])
      until Upper = Lower;
      Exchange(Data[Upper],Data[Last]);          { Move pivot value to partion the group }
      QuickSort(First,pred(Upper));              { Sort the top group }
      QuickSort(succ(Upper),Last)                { Sort the bottom group }
      end
    end;
  {$A+}

  procedure CheckEndOfPage;
    { Test if it is time to go to the next page }
    var I: integer;
    begin
    if LineNumber+3 > succ(PageLength-PageMargin) then
      begin
      for I := LineNumber to pred(PageLength+PageMargin) do
        writeln(OutputFile);
      if OutputFileName='CON:' then
        begin
        write('                      --  Hit any key to continue  --');
        read(kbd,Ch);
        writeln
        end;
      LineNumber := PageMargin
      end
    end;

  begin
  if OutputFileName<>'CON:' then
    writeln('Generating report...');
  for I := 0 to OverlayGroupNumber do
    begin
    assign(InputFile,TempFileName(I));
    reset(InputFile);
    RoutineNum := 0;
    while not eof(InputFile) and (RoutineNum<MaxRoutinesInGroup) do  { Read in overlay group data }
      begin
      RoutineNum := succ(RoutineNum);
      readln(InputFile,Data[RoutineNum].ProcFunc,Data[RoutineNum].Size,Data[RoutineNum].Name)
      end;
    close(InputFile);
    if SortMode<>0 then                          { Optionally sort the output data }
      QuickSort(1,RoutineNum);

    for J := 1 to PageMargin do
      writeln(OutputFile);
    writeln(OutputFile,'                                       Length in  Length in  Bytes to  Capacity');
    writeln(OutputFile,'                                         bytes     records     spare     used  ');
    writeln(OutputFile,'                                       ---------  ---------  --------  --------');
    writeln(OutputFile,'OVERLAY GROUP ',I:2,1.0*QuantizationSize*OverlayGroupSize[I]:30:0,OverlayGroupSize[I]:10);
    LineNumber := PageMargin + 5;
    for RoutineNum := 1 to RoutineNum do
      begin
      CheckEndOfPage;
      writeln(OutputFile);
      if Data[RoutineNum].ProcFunc='F'
       then
        write(OutputFile,'function',Data[RoutineNum].Name,'':31-length(Data[RoutineNum].Name))
       else
        write(OutputFile,'procedure',Data[RoutineNum].Name,'':30-length(Data[RoutineNum].Name));
      writeln(OutputFile,Data[RoutineNum].Size:7,(Data[RoutineNum].Size+QuantizationSize-1) div QuantizationSize:10,
                         1.0*QuantizationSize*OverlayGroupSize[I]-Data[RoutineNum].Size:11:0,
                         100.0*Data[RoutineNum].Size/(1.0*QuantizationSize*OverlayGroupSize[I]):10:1,' %');
      for J := 1 to round(79.0*Data[RoutineNum].Size/(1.0*QuantizationSize*OverlayGroupSize[I])) do
        write(OutputFile,'X');
      writeln(OutputFile);
      LineNumber := LineNumber+3
      end;
    for J := LineNumber to PageLength do
      writeln(OutputFile);
    if (OutputFileName='CON:') and (I<>OverlayGroupNumber) then
      begin
      write('                      --  Hit any key to continue  --');
      read(kbd,Ch);
      writeln
      end;

    erase(InputFile)
    end;
  close(OutputFile)
  end;

begin
writeln('Overlay mapper version ',RevisionNumber,' for ',MachineType,' Turbo Pascal.');
writeln('  by Scott Bussinger -- ',RevisionDate);
writeln;

EnterParameters;

IncludeFlag := false;
LastChar := ' ';
OverlayGroupNumber := -1;
for I := 0 to 99 do
  OverlayGroupSize[I] := 0;
ReUseNextWord := false;

writeln('Analyzing');
LineCount := -1;
BumpLineCount;

while GetNextWord(CurrentWord) do
  if CompareWord(CurrentWord,'OVERLAY') then
    ScanForOverlayGroup;
close(InputFile);

writeln(^M'  ',LineCount);
OutputDataCollected;
write(^G'Analysis complete.')
end.