home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol6n20.zip / PROFIL.ZIP / PROFILE.INC < prev    next >
Text File  |  1987-01-11  |  4KB  |  152 lines
  1. const
  2.   NumBins = 4096 ;
  3.   PRF_OK : boolean = false ;
  4. type
  5.   PRF_String255 = string[255] ;
  6.   PRF_Rec = record
  7.              CountSeg,
  8.              CountOfs,
  9.              BlockSize,
  10.              BinSize  : integer ;
  11.              Active   : boolean ;
  12.            end;
  13.   PRF_LongString = array[0..maxint] of char;
  14. var
  15.   PRF_DataPtr : ^PRF_Rec ;
  16.  
  17.  
  18. { Get the address of the parameters needed by Profile, as stored in the       }
  19. { environment string by the main program                                      }
  20. { This is adapted from a routine in INVOKE.PAS.                               }
  21.  
  22. function PRF_match( Env : PRF_LongString;
  23.                     Org : integer;
  24.                     TestString : PRF_string255 ) : boolean;
  25. var
  26.   Index : integer;
  27. begin
  28.   Index := 0;
  29.   while ( (Index < length( TestString ) ) and
  30.           ( Env[ Org + Index ] = TestString[ succ(Index) ] ) ) do
  31.           Index := succ(Index);
  32.   PRF_match := Index = length( TestString );
  33. end; { function PRF_match }
  34.  
  35. function PRF_GetEnvStr( SearchString : PRF_string255 ) : PRF_string255;
  36. var
  37.   CurChar,
  38.   Index     : integer;
  39.   found,
  40.   error     : boolean;
  41.   EnvString : ^PRF_Longstring;
  42.   OutStr    : PRF_string255;
  43. begin
  44.   CurChar := 0;
  45.   found := false;
  46.   error := false;
  47.   EnvString := ptr( memW[ Cseg:$2C ], 0 );
  48.   repeat
  49.     if EnvString^[ CurChar ] = chr(0) then
  50.        error := true
  51.     else if PRF_match( EnvString^, CurChar, SearchString) then
  52.     begin
  53.       CurChar := CurChar + length( SearchString );
  54.       found := true;
  55.     end
  56.     else
  57.     begin
  58.       while EnvString^[ CurChar ] <> chr(0) do
  59.             CurChar := succ(CurChar);
  60.       CurChar := succ(CurChar);
  61.     end;
  62.   until (found or error);
  63.   OutStr := '';
  64.   if found then
  65.      while EnvString^[ CurChar ] <> chr(0) do
  66.      begin
  67.        OutStr := OutStr + EnvString^[ CurChar ];
  68.        CurChar := succ(CurChar);
  69.      end; { while }
  70.   PRF_GetEnvStr := OutStr;
  71. end; { function PRF_GetEnvStr( SearchString : PRF_string255 )  }
  72.  
  73.  
  74. { Set the profiler to keep track of execution addresses from Segm:LowOfs      }
  75. { through Segm: HiOfs                                                         }
  76.  
  77. procedure PRF_Init( Segm, LowOfs, HiOfs : integer ) ;
  78. var
  79.   DataStr : PRF_String255 ;
  80.   Code,
  81.   Segment,
  82.   Offset  : integer ;
  83.   ch      : char ;
  84.  
  85. begin
  86.   DataStr := PRF_GetEnvStr( 'PRFDATA=' ) ;
  87.   if pos( ':', DataStr ) = 0 then
  88.   begin
  89.     WriteLn( 'Missing parameter from Profiler.' ) ;
  90.     WriteLn( 'Press any key to continue...' ) ;
  91.     Read( KBD, ch ) ;
  92.     Halt ;
  93.   end ;
  94.   val( copy( DataStr, 1, pred( pos( ':', DataStr ) ) ), Segment, Code ) ;
  95.   if Code <> 0 then
  96.   begin
  97.     WriteLn( 'Invalid parameter from Profiler.' ) ;
  98.     WriteLn( 'Press any key to continue...' ) ;
  99.     Read( KBD, ch ) ;
  100.     Halt ;
  101.   end ;
  102.   val( copy( DataStr, succ( pos( ':', DataStr ) ), 5 ), Offset, Code ) ;
  103.   if Code <> 0 then
  104.   begin
  105.     WriteLn( 'Invalid parameter from Profiler.' ) ;
  106.     WriteLn( 'Press any key to continue...' ) ;
  107.     Read( KBD, ch ) ;
  108.     Halt ;
  109.   end ;
  110.   PRF_DataPtr := Ptr( Segment, Offset ) ;
  111.   PRF_OK := true ;
  112.   with PRF_DataPtr^ do
  113.   begin
  114.     CountSeg := Segm ;
  115.     CountOfs := LowOfs ;
  116.     BlockSize := HiOfs - LowOfs - 1 ;
  117.     BinSize := succ( trunc( 1.*BlockSize/NumBins ) ) ;
  118.   end;
  119. end; { procedure PRF_Init( Segm, LowOfs, HiOfs : integer )  }
  120.  
  121. { Start profiler }
  122. procedure PRF_Start ;
  123. var
  124.   ch : char ;
  125. begin
  126.   if PRF_OK then
  127.      PRF_DataPtr^.Active := true
  128.   else
  129.   begin
  130.     WriteLn( 'Attempt to start Profiler without initialization.' ) ;
  131.     WriteLn( 'Press any key to continue...' ) ;
  132.     Read( KBD, ch ) ;
  133.     Halt ;
  134.   end;
  135. end; { procedure PRF_Start  }
  136.  
  137. { Stop profiler }
  138. procedure PRF_Stop ;
  139. var
  140.   ch : char ;
  141. begin
  142.   if PRF_OK then
  143.      PRF_DataPtr^.Active := false
  144.   else
  145.   begin
  146.     WriteLn( 'Attempt to stop Profiler without initialization.' ) ;
  147.     WriteLn( 'Press any key to continue...' ) ;
  148.     Read( KBD, ch ) ;
  149.     Halt ;
  150.   end;
  151. end; { procedure PRF_Stop  }
  152.