PROGRAM prohst(input,output);
{$debug- $line- $symtab+}

{**********************************************************************}
{*                                                                    *}
{*                           prohst                                   *}
{*                                                                    *}
{* This program produces a histogram from the profile file produced   *}
{* by the MS-DOS profile utility. It optionally reads the map file    *}
{* generated when the program being profiled was linked, and writes   *}
{* either the module address or, if available, the line number as     *}
{* a prefix to the line of the graph which describes a particular     *}
{* bucket.                                                            *}
{*                                                                    *}
{* After using filbm (derived from the Pascal and Fortran front end   *}
{* command scanner) to parse its parameters, prohst opens the map     *}
{* file if specified, searches for the heading line, and then reads   *}
{* the lines giving the names and positions of the modules. It builds *}
{* a linked list of module names and start addresses.                 *}
{*                                                                    *}
{* It then reads the bucket file header and and bucket array elements *}
{* into a variable created on the heap. It simultaneously calculates  *}
{* a normalization factor. It writes the profile listing header and   *}
{* starts to write the profile lines. For each bucket, the address    *}
{* is calculated. The first entry in the address/name linked list     *}
{* is the lowest addressed module. This is initially the 'current'    *}
{* module. The bucket address is compared with the current module     *}
{* address. When it becomes the greater, the module name is written   *}
{* to the listing and the next entry in the address/name list becomes *}
{* the current module. If line numbers are available, the bucket      *}
{* address is also compared to the current line/address. This is      *}
{* read and calculated directly from the file. Since there may be     *}
{* more than one line per bucket, several entries may be read until   *}
{* the addresses compare within the span of addresses encompassed by  *}
{* a bucket (its 'width'). Note that the idiosyncracies of Pascal i/o *}
{* make it necessary to continually check for the end of the map file *}
{* and the complexity of this code is mainly due to an attempt to     *}
{* make it reasonably resilient to changes in the format of the map   *}
{* file.                                                              *}
{*                                                                    *}
{**********************************************************************}


CONST
  max_file = 32;


TYPE
  filenam = LSTRING (max_file);
  sets = SET OF 0..31;
  address_pointer = ^address_record;
  address_record = RECORD
                     next: address_pointer;
                     name: STRING (15);
                     address: WORD;
                   END;

        



VAR

  i: INTEGER;
  bucket: FILE OF WORD;
  hist: TEXT;
  map: TEXT;

  first_address,
  this_address: address_pointer; 
  current_base: WORD;
  bucket_name,
  hist_name,
  map_name: filenam;

  switches: sets;

  line: LSTRING (100);

  map_avail: BOOLEAN;
  line_nos_avail: BOOLEAN;

  norm: REAL;
  per_cent: INTEGER;
  real_bucket,
  norm_bucket: REAL;
  cum_per_cent,
  real_per_cent: REAL;

  bucket_num,
  clock_grain,
  bucket_size,
  prog_low_pa,
  prog_high_pa,
  dos_pa,
  hit_io,
  hit_dos,
  hit_high: WORD;

  seg,
  offset,
  parcel: WORD;

  address: WORD;
  new_line_no,
  line_no: WORD;

  dummy : LSTRING (8);
  name: LSTRING (20);
  line_no_part: LSTRING (17);
  start: LSTRING (6);

  buckets: ^SUPER ARRAY [1 .. *] OF REAL;

  this_bucket: WORD;

LABEL 1;


PROCEDURE filbm (VAR prffil, hstfil, mapfil: filenam;
                      VAR switches: sets); EXTERN;

FUNCTION realword (w: WORD): REAL;
BEGIN
  IF ORD (w) < 0 THEN BEGIN
    realword := FLOAT (maxint) + FLOAT (ORD (w - maxint));
    END
  ELSE BEGIN
    realword := FLOAT (ORD(w));
  END {IF};
END {realword};



PROCEDURE skip_spaces;
BEGIN
  WHILE NOT eof(map) AND THEN map^ = ' ' DO BEGIN
    get (map);
  END {WHILE};
END {skip_spaces};


FUNCTION hex_char (ch: CHAR): WORD;
BEGIN
  IF ch >= '0' AND THEN ch <= '9' THEN BEGIN
    hex_char := WRD (ch) - WRD ('0');
    END
  ELSE IF ch >= 'A' AND THEN ch <= 'F' THEN BEGIN
    hex_char := WRD (ch) - WRD ('A') + 10;
    END
  ELSE BEGIN
    WRITELN ('Invalid hex character');
    hex_char := 0;
  END {IF};
END {hex_char};


FUNCTION read_hex (i :WORD): WORD;
VAR
  hex_val: WORD;
BEGIN
  skip_spaces;
  hex_val := 0;
  WHILE NOT eof (map) AND THEN i <> 0 DO BEGIN
    hex_val := hex_val * 16 + hex_char (map^);
    GET (map);
    i := i - 1;
  END {WHILE};
    read_hex := hex_val;
END {read_hex};

FUNCTION read_h: WORD;
BEGIN
  read_h := read_hex (4);
  get (map);
  get (map);
END;

FUNCTION read_word: WORD;
VAR 
  int_value: WORD;
BEGIN
  int_value := 0;
  IF NOT EOF (map) THEN BEGIN
    READ (map, int_value);
  END {IF};
  read_word := int_value;
END {read_word};


FUNCTION map_digit: BOOLEAN;
BEGIN
  map_digit := (map^ >= '0') OR (map^ <= '9');
END {map_digit};

BEGIN {prohst}
  writeln (output, '    Profile Histogram Utility - Version 1.0');
  writeln (output);
  writeln (output, '         Copyright - Microsoft, 1983');
         
  start := '      ';

  filbm (bucket_name, hist_name, map_name, switches);

  IF 31 IN switches THEN BEGIN
    ABORT ('Map file must not be terminal', 0, 0);
  END {IF};

  IF NOT (28 IN switches) THEN BEGIN
    ABORT ('No histogram file specified', 0, 0);
  END {IF};

  ASSIGN (bucket, bucket_name);
  reset (bucket);
  ASSIGN (hist, hist_name);
  rewrite (hist);
  
  map_avail := 29 IN switches;
  line_nos_avail := FALSE;

  IF map_avail THEN BEGIN
    ASSIGN (map, map_name);
    RESET (map);
  
    WHILE NOT EOF (map) AND THEN start <> ' Start' DO BEGIN
      READLN (map, start);
    END {WHILE};
    
    NEW (first_address);
    this_address := NIL;

    WHILE NOT EOF(map) DO BEGIN
      READLN (map, line);
      IF line.len < 6 OR ELSE line [2] < '0' OR ELSE
          line [2] > '9' THEN BEGIN
        BREAK;
      END {IF};

      IF this_address <> NIL THEN BEGIN
        NEW (this_address^.next);
        this_address := this_address^.next;
        END
      ELSE BEGIN
        this_address := first_address;
      END {IF};
      this_address^.next := NIL;

      this_address^.address := (hex_char (line [2]) * 4096) + 
                               (hex_char (line [3]) * 256) +   
                               (hex_char (line [4]) * 16) + 
                               hex_char (line [5]);

      FOR i := 1 TO 15 DO BEGIN
        this_address^.name [i] := line [22 + i];
      END {FOR};

    END {WHILE};

    WHILE NOT EOF (map) DO BEGIN
      READLN (map, line_no_part);
      IF line_no_part = 'Line numbers for ' THEN BEGIN
        line_nos_avail := TRUE;
        BREAK;
      END {IF};
    END {WHILE};
    
  END {IF};

  read (bucket, clock_grain, bucket_num, bucket_size,
    prog_low_pa, prog_high_pa, dos_pa, hit_io, hit_dos, hit_high);

  NEW (buckets,ORD (bucket_num));

  norm := 0.0;
  norm_bucket := 0.0;

  FOR i := 1 TO ORD (bucket_num) DO BEGIN
    read (bucket, this_bucket);
    real_bucket := realword (this_bucket);

    IF real_bucket > norm_bucket THEN BEGIN
      norm_bucket := real_bucket;
    END {IF};

    norm := norm + real_bucket;
    buckets^[i] := real_bucket;
  END {FOR};
  norm_bucket := 45.0/norm_bucket;
  norm := 100.0/norm;

  WRITELN (hist, 'Microsoft Profiler Output Listing');
  
  WRITELN (hist);
  WRITELN (hist, ORD (bucket_num):6, bucket_size:4,'-byte buckets.');

  WRITELN (hist);
  WRITELN (hist, 'Profile taken between ', prog_low_pa*16::16,
    ' and ', prog_high_pa*16::16, '.');

  WRITELN (hist);
  WRITELN (hist, 'DOS program address:', dos_pa::16);

  WRITELN (hist);
  WRITELN (hist, 'Number of hits in DOS: ', hit_dos:5, 
            ' or ', realword (hit_dos) * norm:4:1, '%.');
  WRITELN (hist, 'Number of hits in I/O: ', hit_io:5,
            ' or ', realword (hit_io) * norm:4:1, '%.');
  WRITELN (hist, 'Number of hits high  : ', hit_high:5,
            ' or ', realword (hit_high) * norm:4:1, '%.');
  WRITELN (hist);
  WRITELN (hist, ' Hits  Addr.  Line/ Cumul.  % 0.0               ',
                              '                         ',
                              1.0/norm:1:1);

  WRITELN (hist, '              Offset           +----------------',
                              '----------------------------');
  WRITELN (hist, name);
  i := 0;
  parcel := 0;
  current_base := 0;
  line_no := 0;
  new_line_no := 0;
  cum_per_cent := 0.0;

  WHILE i < ORD (bucket_num) DO BEGIN
    i := i + 1;
    IF buckets^[i] < 0.9 THEN BEGIN
      WRITELN (hist);
      REPEAT
        i := i + 1;
      UNTIL (i = ORD (bucket_num)) OR ELSE buckets^[i] > 0.0;
    END {IF};

    address := bucket_size * (WRD (i) - 1);
    
    WHILE map_avail AND THEN
        address >= first_address^.address DO BEGIN
      WRITELN (hist, '      ', first_address^.name);
      current_base := first_address^.address;
      first_address := first_address^.next;
    END {WHILE};

    WHILE line_nos_avail AND THEN NOT eof (map) AND THEN
                                       address >= parcel DO BEGIN
      skip_spaces;
      WHILE  (map^ < '0') OR (map^ > '9') DO BEGIN
      
        IF EOF (map) THEN BEGIN
          goto 1;
        END {IF};
        READLN (map);
        skip_spaces;
      END {WHILE};


      line_no := new_line_no;
      new_line_no := read_word;
      seg := read_hex (4);
      IF EOF (map) THEN BEGIN
        GOTO 1;
      END {IF};
      IF map^ <> ':' THEN BEGIN
        WRITELN ('Invalid map file');
      END {IF};
      get (map);
      IF EOF (map) THEN BEGIN
        GOTO 1;
      END {IF};
      offset := read_hex (3) + WRD (hex_char (map^) > 0);
      get (map);
      IF map^ <> 'H' THEN BEGIN
        WRITELN ('Invalid map file');
      END {IF};
      IF EOF (map) THEN BEGIN
        GOTO 1;
      END {IF};
      get (map);
      parcel := seg + offset;
    END {WHILE};
1:  real_per_cent := buckets^[i] * norm;
    cum_per_cent := cum_per_cent + real_per_cent;
    per_cent := ROUND ( buckets^[i] * norm_bucket);

    WRITE (hist, buckets^ [i]:6:0, ' ',
               address*16:6:16);
    IF line_no <> 0 THEN BEGIN 
      WRITE (hist, line_no:6);
      line_no := 0;
      END
    ELSE IF map_avail AND THEN first_address <> NIL THEN BEGIN
      WRITE (hist, ' #', address - first_address^.address:4:16);
      END
    ELSE BEGIN
      WRITE (hist, '      ');
    END {IF};
    
    WRITELN (hist, ' ', cum_per_cent:5:1, ' ', real_per_cent:4:1, ' |',
               '*': per_cent);
  END {WHILE};
  WRITELN (hist, '                               +-----------------',
                              '------------------');
END.