(*
  :Program.       OProf.mod (OProf)
  :Author.        Volker Rudolph
  :Address.       Lettow-Vorbeck-Str. 11 / 6750 Kaiserslautern 26
  :Phone.         06301/8566
  :Version.       1.22
  :Date.          4.11.90
  :Copyright.     Volker Rudolph (Shareware)
  :Language.      Oberon
  :Translator.    Oberon V1.17.1
  :Imports.       MicroTimer, Printf
  :Contents.      Laufzeit-Statistiken über Programme
*)

MODULE OProf;

IMPORT a:Arguments,as:ASCII,Break,NoGuru,st:Strings,p:Printf,io,l:Lists,s:SYSTEM,
       ex:Expressions,te:Text,pr:ProfRunTime;

CONST
  DEBUG = FALSE;

TYPE
  CHARPtr = POINTER TO CHAR;

VAR
  trace:INTEGER;

(* ------------------------------------------------------------------------- *)

PROCEDURE HashValue(VAR proc:pr.ProcName):INTEGER;
VAR
  i:INTEGER;
  hash:LONGINT;
BEGIN
  i := 0;
  hash := 0;
  WHILE (i < pr.ProcNameLen) AND (proc[i] # as.nul) DO
    (* $OvflChk- *)
    hash := hash * 3 + ORD(proc[i]);
    (* $OvflChk= *)
    INC(i);
  END; (* WHILE *)
  IF hash = -32768 THEN
    hash := 0;
  ELSIF hash < 0 THEN
    hash := -hash;
  END; (* IF *)
  RETURN SHORT(hash MOD pr.HashTableSize);
END HashValue;

(* -------------------------------------------------------------------------- *)

(* StackChk+ *)
PROCEDURE ExamineText;
VAR
  node:l.NodePtr;
  prev:l.NodePtr;
  type:INTEGER;
  str:pr.ProcName;

  PROCEDURE ModifyImport;
  VAR
    node:l.NodePtr;
    type:INTEGER;
    str:pr.ProcName;
    ok:BOOLEAN;
  BEGIN
    node := l.Head(te.ExList);
    IF te.FindKeyWord({te.import},node,type) THEN
      str := " prof:ProfRunTime,";
      te.AddExpression(str,node,FALSE);
    ELSIF te.FindKeyWord({te.module},node,type) THEN
      WHILE (node # NIL) AND
            ( ((node IS te.MaxExNode) AND ~node(te.MaxExNode).semicolon) OR
              ((node IS te.MinExNode) AND ~node(te.MinExNode).semicolon)
            ) DO
        ok := l.Next(node);
      END; (* WHILE *)
      IF node # NIL THEN
        str := "\nIMPORT prof:ProfRunTime;\n\n";
        te.AddExpression(str,node,TRUE);
      END; (* IF *)
    ELSE
      pr.Assert(FALSE,"Format-error in sourcecode");
    END; (* IF *)
  END ModifyImport;

  PROCEDURE AddEntryExit(scope:pr.ProcName;key:INTEGER):BOOLEAN;
  VAR
    found:INTEGER;
    newScope:pr.ProcName;
    function:BOOLEAN;
    noBody:BOOLEAN;
    ok:BOOLEAN;
    ch:CHAR;

    PROCEDURE SetNewScope;
    VAR
      exPtr:CHARPtr;
      i,end:INTEGER;
      ok:BOOLEAN;
    BEGIN
      ok := l.Next(node);
      i := st.Length(newScope);
      IF node^ IS te.MaxExNode THEN
        exPtr := s.VAL(CHARPtr,node(te.MaxExNode).expression);
        end := i + node^(te.MaxExNode).len;
      ELSE
        exPtr := s.ADR(node^(te.MinExNode).expression);
        end := i + node^(te.MinExNode).len;
      END; (* IF *)
      IF i > 0 THEN
        newScope[i] := '.';
        INC(i);
      END; (* IF *)
      WHILE ex.IsASCII(exPtr^) AND (i < end) AND (i < pr.ProcNameLen-1) DO
        newScope[i] := exPtr^;
        INC(i);
        INC(exPtr);
      END; (* WHILE *)
      newScope[i] := as.nul;
    END SetNewScope;

    PROCEDURE Prev(node:l.NodePtr):l.NodePtr;
    VAR
      ok:BOOLEAN;
    BEGIN
      ok := l.Previous(node);
      RETURN node;
    END Prev;

    PROCEDURE GetLastChar(node:l.NodePtr):CHAR;
    VAR
      i:INTEGER;
      p:ex.MaxExpressionPtr;
    BEGIN
      IF node IS te.MaxExNode THEN
        p := node(te.MaxExNode).expression;
      ELSE
        p := s.ADR(node(te.MinExNode).expression);
      END; (* IF *)
      i := st.Length(p^)-1;
      WHILE (i >= 0) AND (p[i] = ' ') DO
        DEC(i);
      END; (* WHILE *)
      IF i >= 0 THEN
        RETURN p[i];
      ELSE
        RETURN ' ';
      END; (* IF *)
    END GetLastChar;

  BEGIN
    IF DEBUG THEN
      p.Printf1("AddEntryExit <%s>\n",s.ADR(scope));
    END; (* IF *)
    ok := l.Next(node);

    newScope := scope;
    function := FALSE;
    noBody := TRUE;

    WHILE te.FindKeyWord({te.end..te.halt},node,found) DO
      CASE found OF
       |te.begin:
          IF (trace # 0) AND (key = te.module) THEN
            p.SPrintf1(str,"prof.Trace := %ld;\n",trace);
            te.AddExpression(str,node,TRUE);
            ok := l.Next(node);
          END; (* IF *)
          p.SPrintf2(str,'prof.Entry("%s",%ld);\n',s.ADR(newScope),HashValue(newScope));
          te.AddExpression(str,node,TRUE);
          function := FALSE;
          noBody := FALSE;
       |te.end:
          IF ((key = te.procedure) OR (key = te.module)) AND ~function AND ~noBody THEN
            prev := Prev(node);
            IF ((prev^ IS te.MaxExNode) AND ~prev^(te.MaxExNode).semicolon ) OR
               ((prev^ IS te.MinExNode) AND ~prev^(te.MinExNode).semicolon ) THEN
              te.AddExpression(";\n",prev,TRUE);
            END; (* IF *)
            p.SPrintf2(str,'prof.Exit("%s",%ld);\n',s.ADR(newScope),HashValue(newScope));
            te.AddExpression(str,Prev(node),TRUE);
          END; (* IF *)
          RETURN function;
       |te.return:
          p.SPrintf2(str,'prof.Exit("%s",%ld);\n',s.ADR(newScope),HashValue(newScope));
          te.AddExpression(str,Prev(node),TRUE);
          function := TRUE;
       |te.halt:
          te.AddExpression("prof.Halt;\n",Prev(node),TRUE);
       |te.procedure,te.module:
          ch := GetLastChar(node);
          IF ch # '^' THEN
            prev := Prev(node);
            ch := GetLastChar(prev);
            IF (ch # '=') AND (ch # ':') THEN
              SetNewScope;
              function := AddEntryExit(newScope,found);
              noBody := TRUE;
              newScope := scope;
            END; (* IF *)
          END; (* IF *)
       |te.if..te.loop:
          function := AddEntryExit(newScope,found);
          newScope := scope;
       |te.close:
          IF ~noBody THEN
            p.SPrintf2(str,'prof.Exit("%s",%ld);\n',s.ADR(newScope),HashValue(newScope));
            te.AddExpression(str,Prev(node),TRUE);
            function := TRUE;
          END; (* IF *)
      ELSE (* te.import *)
      END; (* CASE *)
      ok := l.Next(node);
    END; (* WHILE *)
    RETURN function;
  END AddEntryExit;

BEGIN
  p.SPrintf0(str,"(* OProf \xA91990 by Volker Rudolph *)\n\n");
  te.AddExpression(str,NIL,FALSE);

  ModifyImport;

  node  := l.Head(te.ExList);
  str := "";
  IF AddEntryExit(str,-1) THEN END;
END ExamineText;
(* StackChk= *)

(* -------------------------------------------------------------------------- *)

PROCEDURE WriteProf(name:ARRAY OF CHAR);
BEGIN
  IF te.ReadText(name) THEN
    ExamineText;
    pr.Assert(te.WriteText(),"WRITE ERROR");
    te.RemText;
  ELSE
    p.Printf0("DISK ERROR\n");
  END; (* IF *)
END WriteProf;

(* -------------------------------------------------------------------------- *)

PROCEDURE DoArgs;
VAR
  i:INTEGER;
  num:INTEGER;
  len:INTEGER;
  arg:ex.String;
  arg2:ex.String;
BEGIN
  p.Printf0("OProf 1.22 \XA91990 by Volker Rudolph\n\n");
  num := a.NumArgs();
  IF num = 0 THEN
    a.GetArg(0,arg);
    p.Printf1("Usage:\n  %s Files/...,TRACE/S,TRACE2/S\n",s.ADR(arg));
  END; (* IF *)
  i := 1;
  WHILE i <= num DO
    a.GetArg(i,arg);
    st.Upper(arg);
    IF arg = "TRACE" THEN
      trace := 1;
    ELSIF arg = "TRACE2" THEN
      trace := 2;
    ELSIF arg = "?" THEN
      a.GetArg(0,arg);
      p.Printf1("Usage:\n  %s Files/...,TRACE/S,TRACE2/S\n",s.ADR(arg));
      HALT(0);
    END; (* IF *)
    INC(i);
  END; (* WHILE *)

  i := 1;
  WHILE i <= num DO
    a.GetArg(i,arg);
    arg2 := arg;
    st.Upper(arg2);
    IF (arg2 # "TRACE") AND (arg2 # "TRACE2") THEN
      len := st.Length(arg);
      IF (len > 3) AND (st.Occurs(arg2,".MOD") = len-4) THEN
        arg[len-4] := as.nul;
        WriteProf(arg);
      ELSE
        WriteProf(arg);
      END; (* IF *)
    END; (* IF *)
    INC(i);
  END; (* WHILE *)
  p.Printf0("\nReady.\n");
END DoArgs;

(* -------------------------------------------------------------------------- *)

BEGIN
  p.writeProc := io.WriteString;
  pr.Quiet := TRUE;
  trace := 0;
  DoArgs;
END OProf.