{$Y-}
program profiler;

{	Author : Earl Chew
	Date   : 9 January 1984

	Interprets the profile data 
generated by the NBS runtime system.}

const
  maxsp = 255;
  namelength = 15;
  flag_word = 052525b;
  progid = "PROFIL";
  stringlength = 15;

type
  versionstring = array [1..80] of char;
  sym_type = record
	       name : array [1..namelength] of char;
	       duration, count, period : real
	     end;
  sym_array = array [1..maxsp] of sym_type;
  key_type = (nam, tim, cnt, per);
  string = array [1..stringlength+1] of char;

var
  nbsversion : @versionstring;
  ticks : real;
  symbol : sym_array;
  key : key_type;
  date_string, time_string : string;
  pro : file of integer;
  out : text;
  sp : integer;
  totaltime : real;

procedure fatal(p, m : string); external;

procedure rerun; external;

procedure date(var s:string); external;

procedure time(var s:string); external;

function gval(o:integer):integer; external;

function iand(i,j:integer):integer; external;

function version:@versionstring; external;

function initialise:boolean;
var
  c : char;
  i : integer;
begin
  nbsversion := version;
  initialise := true;
  key := nam;
  if iand(gval(300b), 32) > 0 then
    ticks := 50.0
  else
    ticks := 60.0;
  if argv[1]@[0] = '-' then begin
    i :=0;
    loop
      i := i+1;
      c := argv[1]@[i];
    exit if c = chr(0);
      if c = 'C' then key := cnt
      else if c = 'N' then key := nam
      else if c = 'P' then key := per
      else if c = 'T' then key := tim
      else initialise := false;
    end
  end;

  if argc = 4 then begin
    reset(pro, argv[2]@, "TIM");
    rewrite(out, argv[3]@, "PRO");
    date(date_string);
    time(time_string)
  end
  else
    initialise := false
end;

function unsigned(n : integer):real;
begin
  if n >= 0 then
    unsigned := float(n)
  else
    unsigned := float(n) +65536.0
end;

procedure readsymbols(var pro:file of integer; var symbol:sym_array; var sp:integer; var totaltime:real);
var
  i, namelen : integer;

begin
  sp := 0;
  totaltime := 0.0;
  while not eof(pro) and (pro@ = flag_word) do begin
    get(pro);
    if sp = maxsp then
      fatal(progid, "Too many subprograms");
    sp := sp+1;
    with symbol[sp] do begin
      duration := unsigned(pro@);
      get(pro);
      duration := duration + unsigned(pro@ mod 256) * 65536.0;
      count := unsigned((pro@ div 256) mod 256) * 65536.0;
      get(pro);
      count := count + unsigned(pro@);
      get(pro);
      if count = 0.0 then
        period := 0.0
      else
        period := duration/count;
      namelen := pro@ mod 256;
      for i := 1 to namelen do begin
	if odd(i) then begin
	  name[i] := chr(pro@ div 256);
	  get(pro)
	end
	else
	  name[i] := chr(pro@)
      end;
      if not odd(namelen) then
	get(pro);
      for i := namelen + 1 to namelength do
        name[i] := ' ';
      if name[1]=chr(0) then begin
        sp := sp - 1;
        totaltime := duration
      end
    end
  end;
  if sp = 0 then
    fatal(progid, "No data available");
  if totaltime = 0.0 then
    fatal(progid, "Bad timing data")
end;

procedure sort(var symbol : sym_array; sp : integer; key : key_type);
var
  last_internal_node, node : integer;
  sym : sym_type;

  function isless(var sym1, sym2 : sym_type) : boolean;
  begin
    with sym1 do begin
      case key of
	nam : isless := name < sym2.name;

	tim : isless := (duration < sym2.duration) or 
			((duration = sym2.duration) and (name < sym2.name));
	cnt : isless := (count < sym2.count) or
			((count = sym2.count) and (name < sym2.name));
	per : isless := (period < sym2.period) or
			((period = sym2.period) and (name < sym2.name))
      end
    end
  end;    {of function}

  procedure sift(node, last_internal_node, last_node : integer);
  var
    sym : sym_type;
    max_child : integer;
  begin
    sym := symbol[node];
    max_child := node;
    while (max_child = node) and (node <= last_internal_node) do begin
      max_child := max_child*2;
      if max_child < last_node then
	if isless(symbol[max_child], symbol[max_child+1]) then
	  max_child := max_child +1;
      if isless(sym, symbol[max_child]) then begin
        symbol[node] := symbol[max_child];
	node := max_child
      end
    end;
    symbol[node] := sym
  end;     {of sift}

begin   {sort}
  last_internal_node := sp div 2;
  for node := last_internal_node downto 1 do
    sift(node, last_internal_node, sp);
  for node := sp downto 2 do begin
    sym := symbol[node];
    symbol[node] := symbol[1];
    symbol[1] := sym;
    sift(1, (node-1) div 2, (node-1))
  end
end;

procedure outtime(var out : text; t : real);
var
  h, m : integer;
begin
  h := trunc(t / (ticks * 60.0 * 60.0));
  t := t - float(h) * (ticks * 60.0 * 60.0);
  m := trunc(t / (ticks * 60.0));
  t := t - float(m) * (ticks * 60.0);
  t := t / ticks;
  if h < 10 then
    write(out, '0');
  write(out, h, ':');
  if m < 10 then
    write(out, '0');
  write(out, m, ':');
  if t < 10.0 then
    write(out, '0', t:4:2)
  else
    write(out, t:5:2)
end;

procedure outheader(var out : text);
begin
  writeln(out,'NBS Profiler ', nbsversion@, date_string:15, time_string:12);
  writeln(out);
  writeln(out, 'NAME':9, 'DURATION':25, 'CALLS':17, 'PERIOD':14);
  writeln(out)
end;

procedure outdata(var out:text; var symbol:sym_array; sp:integer; totaltime:real);
var
  i : integer;
begin
  outheader(out);
  for i := 1 to sp do begin
    with symbol[i] do begin
      write(out, name:15, ' ':5);
      outtime(out, duration);
      write(out, duration * 100.0 / totaltime:8:2, '%');
      if count = 16777215.0 then
        write(out, '>16777214':14)
      else
        write(out, count:14:0);
      write(out, ' ':3);
      outtime(out, period);
      writeln(out)
    end
  end
end;

begin   {main}
  if initialise then begin
    readsymbols(pro, symbol, sp, totaltime);
    sort(symbol, sp, key);
    outdata(out, symbol, sp, totaltime)
  end
  else begin
    writeln('NBS Profiler ', nbsversion@);
    writeln;
    writeln('$-[CNPT] timing output');
    writeln;
    writeln('-C  sort on subprogram call count');
    writeln('-N  sort on subprogram name : default');
    writeln('-P  sort on average period');
    writeln('-T  sort on total time spent in subprogram');
    writeln;
    rerun
  end
end.