ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/PNL004.ZIP/PROFILER.PAS

Pascal/Delphi Source File | 1990-05-19 | 17.9 KB | 507 lines

program profiler;

(* (c) Jan-Erik Rosinowski 1989 *)

{$A+,B-,D+,E+,F-,I+,L+,N-,O-,R-,S+,V-}
{$M 16384,0,655360}

uses
  crt;

const
  stacksize        = 50;
  prounitname      = 'Profile';
  probegin         = '.PBegin(';
  proend           = '.PEnd';
  prospec          = '.SpecFile(';
  tempfileextension= '.PR$';
  profileextension = '.PRF';
  initidentifier   = '(INIT)';

type
  string20         = string[20];
  string30         = string[30];
  proctypes        = (_program,_unit,_function,_procedure,skipit);
  stacktype        = array[0..stacksize] of record
                                              procname : string30;
                                              procnr   : word;
                                              proctype : proctypes;
                                              written  : boolean;
                                            end;
  listelementptr   = ^listelementtype;
  listelementtype  = record
                       name     : string30;
                       next     : listelementptr;
                     end;

var
  stack            : stacktype;        (* storage for proc's and func's *)
  stackptr         : word;
  proccntr         : word;             (* non-recursive count of proc
                                          headers seen *)
  beginlevel       : word;             (* begin inc's, end dec's *)
  recordlevel      : word;             (* record inc's, case:-, end dec's *)
  handledmodules   : listelementptr;   (* list of modules yet seen *)
  showhelp         : boolean;
  error            : boolean;          (* error ocurred while 'precompiling' *)
  main             : string20;         (* name of main module *)
  scanmsgline      : word;             (* row of message text *)
  tempfile         : text;             (* .PR$ - file *)
  nameoftempfile   : string;           (* it's name *)
  q                : word;             (* don't bother *)

function upcasestr(s:string):string;
var
  q                : word;
begin
  for q:=1 to length(s) do s[q]:=upcase(s[q]);
  upcasestr:=s;
end;

function fixname(s:string20):string20;
begin
  if pos('.',s)=0 then s:=s+'.PAS';
  fixname:=upcasestr(s);
end;

procedure includeinlist(var ptr:listelementptr; name:string20);
var
  temp             : listelementptr;
begin
  new(temp);
  temp^.next:=ptr; temp^.name:=fixname(name);
  ptr:=temp;
end;

function inlist(ptr:listelementptr; name:string20):boolean;
begin
  name:=fixname(name);
  while (ptr<>nil) and (ptr^.name<>name) do ptr:=ptr^.next;
  inlist:=ptr<>nil;
end;

function prep_module(path:string; nameofprg:string20):boolean;
const
  maxkeywords      = 19;
  keyword          : array[1..maxkeywords+1] of string30 =
                     ('PROGRAM','UNIT','USES','INTERFACE','IMPLEMENTATION',
                      'PROCEDURE','FUNCTION','BEGIN','END',
                      'RECORD','CASE','EXTERNAL','INLINE','INTERRUPT',
                      'CONST','TYPE','VAR','FORWARD','EXIT','');

var
  source           : text;             (* source-file *)
  inputbuffer      : pointer;          (* buffer for source-file *)
  destination      : text;             (* destination-file *)
  bakname          : string20;         (* new name of original file *)
  symbol           : string;           (* words as UNIT,BEGIN,... *)
  upcasedsymbol    : string;           (* ..upcased *)
  kw               : word;             (* symbols' token *)
  usesrequired     : boolean;          (* include of USES required *)
  nextidentifier   : proctypes;        (* put next symbol on stack *)
  interfacemode    : boolean;          (* don't care about PROCEDURE,
                                          FUNCTION,..*)
  pending          : char;             (* read but not yet handled char *)
  error            : boolean;          (* error flag *)

procedure getsymbol(var symbol:string);
const
  alphanum         = ['A'..'Z','a'..'z','0'..'9','_'];
var
  ch               : char;             (* buffer for last read char *)
  lastch           : char;             (* buffer for char read previous to
                                          ch *)
  intext           : boolean;          (* we're scanning text-constant *)
  again            : boolean;          (* so far only shit, repeat it *)
  directive        : boolean;          (* compiler directive recognised *)

procedure handledirective;
var
  s                : string30;

function getoption(s:string30):string30;
var
  q,w              : word;
begin
  q:=1;
  while s[q]=' ' do inc(q);
  w:=length(s);
  while s[w]=' ' do dec(w);
  getoption:=copy(s,q,w-q+1);
end;

begin
  write(destination,symbol);
  s:=upcasestr(copy(symbol,3+ord(symbol[1]='('),
                 length(symbol)-3-2*ord(symbol[1]='(')));
  if copy(s,1,2)='I ' then error:=not prep_module(path+'/'+nameofprg,
                                        getoption(copy(s,3,length(s)-2)));
  if not error then again:=true;
end;

begin
  repeat
    directive:=false;
    again:=false;
    ch:=pending;
    if ch=#0 then read(source,ch);
    while not eof(source) and ((ch=' ') or (ch=#13) or (ch=#10) or (ch=#0)) do
      begin
        if ch<>#0 then write(destination,ch);
        read(source,ch);
      end;
    symbol:='';
    if (ch='(') or (ch='{') or (ch='''') then
      begin
        lastch:=ch;
        read(source,ch);
        symbol:=lastch+ch;
        if (lastch='{') or (symbol='(*') or (lastch='''') then
          begin              (* comment/directive/textconstant *)
            if (lastch='{') or (lastch='''') then
              directive:=symbol='{$'
            else
              begin
                read(source,ch);
                symbol:=symbol+ch;
                directive:=symbol='(*$';
              end;
            if not directive then write(destination,symbol);
            if (symbol<>'{}') and (symbol<>'''''') then
              repeat
                lastch:=ch;
                read(source,ch);
                if directive then symbol:=symbol+ch
                else write(destination,ch);
              until ((symbol[1]='{') and (ch='}'))
                 or ((symbol[1]='(') and (lastch+ch='*)'))
                 or ((symbol[1]='''') and (ch=''''));
            pending:=#0;
            again:=not directive;
          end
        else
          begin
            write(destination,lastch);
            pending:=ch;
            nextidentifier:=skipit;
            again:=true;
          end;
      end
    else
      if ch in alphanum then
        begin                  (* identifier or so *)
          repeat
            symbol:=symbol+ch;
            read(source,ch);
          until eof(source) or not (ch in alphanum);
          pending:=ch;
        end
      else
        begin
          symbol:=ch;
          pending:=#0;
        end;
    if directive then handledirective;
  until not again;
end;

procedure checkusesrequired;           (* check whether to include USES
                                          profilerunit *)
begin
  if usesrequired then
    begin
      writeln(destination,'USES ',prounitname,';');
      usesrequired:=false;
    end;
end;

procedure scanmsg(s:string);           (* for your eyes only *)
begin
  if scanmsgline=0 then scanmsgline:=wherey;
  gotoxy(1,scanmsgline);
  write('Scanning ',s);
  if s='' then write('finished.',' ':15) else write(' ':15);
end;

procedure maketempfile;
var
  s                : string;
  q                : word;
begin
  with stack[stackptr] do
    if (stackptr>0) and not written then
      begin
        write(tempfile,procnr:4,' ');
        case proctype of
          _program   : write(tempfile,'Prog ');
          _unit      : write(tempfile,'Unit ');
          _procedure : write(tempfile,'Proc ');
          _function  : write(tempfile,'Func ');
          end;
        q:=stackptr+1; s:='';
        repeat
          dec(q);
          s:=stack[q].procname+'.'+s;
        until (stack[q].proctype=_unit) or (q<=2);
        s[0]:=chr(pred(length(s)));
        if stack[stackptr].proctype=_unit then s:=s+initidentifier;
        writeln(tempfile,s,' ':50-length(s));
        written:=true;
      end;
end;

begin
  usesrequired:=path='';  (* there might be no PROGRAM-Identifier *)
  error:=false;
  interfacemode:=false;
  pending:=#0;
  nextidentifier:=skipit;
  nameofprg:=upcasestr(nameofprg);
  if not inlist(handledmodules,nameofprg) then
    begin
      nameofprg:=fixname(nameofprg);
      includeinlist(handledmodules,nameofprg);
      bakname:=nameofprg;
      bakname[length(bakname)]:=nameofprg[length(nameofprg)-2];
      bakname[length(bakname)-2]:=nameofprg[length(nameofprg)];
      assign(source,nameofprg);
      assign(destination,nameofprg);
      (*$i-*)
      rename(source,bakname);
      (*$i+*)
      if ioresult<>0 then
        begin
         writeln;
         writeln('(',nameofprg,') not found or failed renaming.');
         error:=path='';
        end
      else
        begin
          reset(source);
          rewrite(destination);
          scanmsg(path+'/'+nameofprg);
          while not (eof(source) or error) do
            begin
              getsymbol(symbol);
              if nextidentifier<>skipit then
                begin
                  write(destination,symbol);
                  maketempfile;
                  inc(proccntr); inc(stackptr);
                  with stack[stackptr] do
                    begin
                      procname:=symbol; procnr:=proccntr;
                      proctype:=nextidentifier; written:=false;
                    end;
                  nextidentifier:=skipit;
                end
              else
                begin
                  upcasedsymbol:=upcasestr(symbol);
                  keyword[maxkeywords+1]:=upcasedsymbol;
                  kw:=1;
                  while upcasedsymbol<>keyword[kw] do inc(kw);
                  case kw of
                    maxkeywords+1 :            (* irrelevant word *)
                           write(destination,symbol);

                    8     :                    (* begin *)
                           begin
                             checkusesrequired;
                             inc(beginlevel);
                             write(destination,symbol);
                             if beginlevel=1 then
                               begin
                                 if stack[stackptr].procnr<2 then
                                   write(destination,' ',prounitname,prospec,
                                     '''',nameoftempfile,'''',',','''',
                                     profileextension,'''',');');
                                 write(destination,' ',prounitname,probegin,
                                   stack[stackptr].procnr,');');
                               end;
                           end;

                    9     :                    (* end *)
                           begin
                             if recordlevel>0 then
                               dec(recordlevel)
                             else
                               if beginlevel>0 then
                                 begin
                                   dec(beginlevel);
                                   if beginlevel=0 then
                                     begin
                                       maketempfile;
                                       write(destination,';',prounitname,
                                         proend,';');
                                       dec(stackptr);
                                     end;
                                 end
                               else
                                 dec(stackptr);  (* units without startcode *)
                             write(destination,symbol);
                           end;

                    6,7   :                    (* function, procedure *)
                           begin
                             checkusesrequired;
                             write(destination,symbol);
                             if not interfacemode then
                               if kw=6 then nextidentifier:=_procedure
                               else nextidentifier:=_function;
                           end;

                    15,16,                     (* const, var, type *)
                    17    :begin
                             checkusesrequired;
                             write(destination,symbol);
                           end;

                    10    :                    (* record *)
                           begin
                             inc(recordlevel);
                             write(destination,symbol);
                           end;

                    11    :                    (* case *)
                           begin
                             if recordlevel=0 then inc(beginlevel);
                             write(destination,symbol);
                           end;

                    12,14,                     (* external, interrupt, *)
                    18,13 :                    (* forward, inline *)
                           begin
                             write(destination,symbol);
                             if not interfacemode
                                and ((kw<>13) or (beginlevel=0))
                                and not stack[stackptr].written then
                               begin
                                 dec(proccntr);
                                 dec(stackptr);
                               end;
                           end;

                    19    :                    (* exit *)
                           write(destination,'begin ',prounitname,proend,
                             ';exit;end;');

                    1,2   :                    (* program, unit *)
                           begin
                             usesrequired:=true;
                             if kw=1 then nextidentifier:=_program
                             else nextidentifier:=_unit;
                             write(destination,symbol);
                           end;

                    3     :                    (* uses *)
                           begin
                             write(destination,symbol,' ');
                             if usesrequired then
                               write(destination,prounitname,',');
                             usesrequired:=false;
                             while (symbol<>';') and not error do
                               begin
                                 repeat
                                   getsymbol(symbol);
                                   write(destination,symbol);
                                 until symbol<>',';
                                 if symbol<>';' then
                                   if symbol=prounitname then
                                     begin
                                       error:=true;
                                       writeln;
                                       writeln('Program already prepared!',#7);
                                     end
                                   else
                                     error:=not prep_module(path+'/'+nameofprg,
                                                  symbol);
                               end;
                           end;

                    4     :                    (* interface *)
                           begin
                             interfacemode:=true;
                             write(destination,symbol);
                           end;

                    5     :                    (* implementation *)
                           begin
                             interfacemode:=false;
                             checkusesrequired;
                             write(destination,symbol);
                           end;

                  end;
                end;
            end;
          close(source);
          if pending<>#0 then write(destination,pending);
          write(destination,#26);
          close(destination);
        end;
    end;
  scanmsg(path);
  prep_module:=not error;
end;

begin
  writeln;
  writeln('Turbo-Profiler  v1.23   (c) Jan-Erik Rosinowski, 1989, 1990');
  stackptr:=0;
  proccntr:=0;
  beginlevel:=0;
  recordlevel:=0;
  scanmsgline:=0;
  handledmodules:=nil;
  includeinlist(handledmodules,'SYSTEM');
  includeinlist(handledmodules,'PRINTER');
  includeinlist(handledmodules,'TURBO3');
  includeinlist(handledmodules,'GRAPH');
  includeinlist(handledmodules,'GRAPH3');
  includeinlist(handledmodules,'DOS');
  includeinlist(handledmodules,'CRT');
  includeinlist(handledmodules,'OVERLAY');
  if paramcount<1 then showhelp:=true
  else
    begin
      showhelp:=false;
      main:=paramstr(1);
      if paramcount>1 then
        begin
          if copy(upcasestr(paramstr(2)),1,2)<>'/X' then showhelp:=true
          else
            for q:=3 to paramcount do
              includeinlist(handledmodules,paramstr(q));
        end;
    end;
  if showhelp then
    begin
      writeln;
      writeln('PROFILER: Optimize your TURBO-Pascal-Programs !');
      writeln('Usage   : PROFILER <Name of main module> [/X: ',
                         '<Modules to exclude>]');
      writeln('                                             ^ mind spaces!');
      writeln;
    end
  else
    begin
      writeln;
      nameoftempfile:=copy(fixname(main),1,
                        length(fixname(main))-4)+tempfileextension;
      assign(tempfile,nameoftempfile);
      rewrite(tempfile);
      error:=not prep_module('',main);
      close(tempfile);
      writeln;
      if error then
        begin
          erase(tempfile);
          writeln('PROFILER terminated due to error!',#7);
        end
      else
        writeln('Program successfully transformed.');
    end;
  halt(ord(error or showhelp));
end.