Category : Files from Magazines
Archive   : VOL6N20.ZIP
Filename : PROFILE.INC

const
NumBins = 4096 ;
PRF_OK : boolean = false ;
type
PRF_String255 = string[255] ;
PRF_Rec = record
CountSeg,
CountOfs,
BlockSize,
BinSize : integer ;
Active : boolean ;
end;
PRF_LongString = array[0..maxint] of char;
var
PRF_DataPtr : ^PRF_Rec ;


{ Get the address of the parameters needed by Profile, as stored in the }
{ environment string by the main program }
{ This is adapted from a routine in INVOKE.PAS. }

function PRF_match( Env : PRF_LongString;
Org : integer;
TestString : PRF_string255 ) : boolean;
var
Index : integer;
begin
Index := 0;
while ( (Index < length( TestString ) ) and
( Env[ Org + Index ] = TestString[ succ(Index) ] ) ) do
Index := succ(Index);
PRF_match := Index = length( TestString );
end; { function PRF_match }

function PRF_GetEnvStr( SearchString : PRF_string255 ) : PRF_string255;
var
CurChar,
Index : integer;
found,
error : boolean;
EnvString : ^PRF_Longstring;
OutStr : PRF_string255;
begin
CurChar := 0;
found := false;
error := false;
EnvString := ptr( memW[ Cseg:$2C ], 0 );
repeat
if EnvString^[ CurChar ] = chr(0) then
error := true
else if PRF_match( EnvString^, CurChar, SearchString) then
begin
CurChar := CurChar + length( SearchString );
found := true;
end
else
begin
while EnvString^[ CurChar ] <> chr(0) do
CurChar := succ(CurChar);
CurChar := succ(CurChar);
end;
until (found or error);
OutStr := '';
if found then
while EnvString^[ CurChar ] <> chr(0) do
begin
OutStr := OutStr + EnvString^[ CurChar ];
CurChar := succ(CurChar);
end; { while }
PRF_GetEnvStr := OutStr;
end; { function PRF_GetEnvStr( SearchString : PRF_string255 ) }


{ Set the profiler to keep track of execution addresses from Segm:LowOfs }
{ through Segm: HiOfs }

procedure PRF_Init( Segm, LowOfs, HiOfs : integer ) ;
var
DataStr : PRF_String255 ;
Code,
Segment,
Offset : integer ;
ch : char ;

begin
DataStr := PRF_GetEnvStr( 'PRFDATA=' ) ;
if pos( ':', DataStr ) = 0 then
begin
WriteLn( 'Missing parameter from Profiler.' ) ;
WriteLn( 'Press any key to continue...' ) ;
Read( KBD, ch ) ;
Halt ;
end ;
val( copy( DataStr, 1, pred( pos( ':', DataStr ) ) ), Segment, Code ) ;
if Code <> 0 then
begin
WriteLn( 'Invalid parameter from Profiler.' ) ;
WriteLn( 'Press any key to continue...' ) ;
Read( KBD, ch ) ;
Halt ;
end ;
val( copy( DataStr, succ( pos( ':', DataStr ) ), 5 ), Offset, Code ) ;
if Code <> 0 then
begin
WriteLn( 'Invalid parameter from Profiler.' ) ;
WriteLn( 'Press any key to continue...' ) ;
Read( KBD, ch ) ;
Halt ;
end ;
PRF_DataPtr := Ptr( Segment, Offset ) ;
PRF_OK := true ;
with PRF_DataPtr^ do
begin
CountSeg := Segm ;
CountOfs := LowOfs ;
BlockSize := HiOfs - LowOfs - 1 ;
BinSize := succ( trunc( 1.*BlockSize/NumBins ) ) ;
end;
end; { procedure PRF_Init( Segm, LowOfs, HiOfs : integer ) }

{ Start profiler }
procedure PRF_Start ;
var
ch : char ;
begin
if PRF_OK then
PRF_DataPtr^.Active := true
else
begin
WriteLn( 'Attempt to start Profiler without initialization.' ) ;
WriteLn( 'Press any key to continue...' ) ;
Read( KBD, ch ) ;
Halt ;
end;
end; { procedure PRF_Start }

{ Stop profiler }
procedure PRF_Stop ;
var
ch : char ;
begin
if PRF_OK then
PRF_DataPtr^.Active := false
else
begin
WriteLn( 'Attempt to stop Profiler without initialization.' ) ;
WriteLn( 'Press any key to continue...' ) ;
Read( KBD, ch ) ;
Halt ;
end;
end; { procedure PRF_Stop }