paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 12:20:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

no message

Browse Source
This commit is contained in:
florian 2002-08-16 20:41:32 +00:00
parent 87088e16fe
commit cee0f217ec
4 changed files with 1493 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

839
tests/bench/dmisc.pas Normal file
View File

@ -0,0 +1,839 @@
{$H-}
unit dmisc;
interface
{$ifndef linux}
{$define MSWindows}
{$endif}
uses
{$ifdef linux}
Libc,
{$else}
windows,
{$endif}
sysutils;
{$ifdef VER100}
type int64 = longint;
{$endif}
Const
Max_Path = 255;
{Bitmasks for CPU Flags}
fcarry = $0001;
fparity = $0004;
fauxiliary = $0010;
fzero = $0040;
fsign = $0080;
foverflow = $0800;
{Bitmasks for file attribute}
readonly = $01;
hidden = $02;
sysfile = $04;
volumeid = $08;
directory = $10;
archive = $20;
anyfile = $3F;
{File Status}
fmclosed = $D7B0;
fminput = $D7B1;
fmoutput = $D7B2;
fminout = $D7B3;
Type
DWord = Cardinal;
{ Needed for Win95 LFN Support }
ComStr = String[255];
PathStr = String[255];
DirStr = String[255];
NameStr = String[255];
ExtStr = String[255];
FileRec = TFileRec;
DateTime = packed record
Year,
Month,
Day,
Hour,
Min,
Sec : word;
End;
SearchRec = Sysutils.TSearchRec;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
Var
DosError : integer;
{Interrupt}
Procedure Intr(intno: byte; var regs: registers);
Procedure MSDos(var regs: registers);
{Info/Date/Time}
Function DosVersion: Word;
Procedure GetDate(var year, month, mday, wday: word);
Procedure GetTime(var hour, minute, second, sec100: word);
Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);
{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function DosExitCode: word;
{Disk}
Function DiskFree(drive: byte) : int64;
Function DiskSize(drive: byte) : int64;
Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(Var f: SearchRec);
{File}
Procedure GetFAttr(var f; var attr: word);
Procedure GetFTime(var f; var tim: longint);
Function FSearch(path: pathstr; dirlist: string): pathstr;
Function FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
{Environment}
Function EnvCount: longint;
Function EnvStr(index: integer): string;
Function GetEnv(envvar: string): string;
{Misc}
Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetCBreak(var breakvalue: boolean);
Procedure SetCBreak(breakvalue: boolean);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);
{Do Nothing Functions}
Procedure SwapVectors;
Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);
implementation
function upper(const s : string) : string;
{
return uppercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
{******************************************************************************
--- Conversion ---
******************************************************************************}
{$ifdef MSWindows}
function GetLastError : DWORD;stdcall;
external 'Kernel32.dll' name 'GetLastError';
function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;stdcall;
external 'Kernel32.dll' name 'FileTimeToDosDateTime';
function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'DosDateTimeToFileTime';
function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'FileTimeToLocalFileTime';
function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'LocalFileTimeToFileTime';
type
Longrec=packed record
lo,hi : word;
end;
function Last2DosError(d:dword):integer;
begin
Last2DosError:=d;
end;
Function DosToWinAttr (Const Attr : Longint) : longint;
begin
DosToWinAttr:=Attr;
end;
Function WinToDosAttr (Const Attr : Longint) : longint;
begin
WinToDosAttr:=Attr;
end;
Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
var
lft : TFileTime;
begin
DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
LocalFileTimeToFileTime(lft,Wtime);
end;
Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
var
lft : TFileTime;
begin
WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
end;
{$endif}
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
procedure intr(intno : byte;var regs : registers);
begin
{ !!!!!!!! }
end;
procedure msdos(var regs : registers);
begin
{ !!!!!!!! }
end;
{******************************************************************************
--- Info / Date / Time ---
******************************************************************************}
function dosversion : word;
begin
dosversion:=0;
end;
procedure getdate(var year,month,mday,wday : word);
begin
DecodeDate(Now,Year,Month,MDay);
WDay:=0;
// DecodeDateFully(Now,Year,Month,MDay,WDay);
end;
procedure gettime(var hour,minute,second,sec100 : word);
begin
DecodeTime(Now,Hour,Minute,Second,Sec100);
Sec100:=Sec100 div 10;
end;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin
sec:=(p and 31) shl 1;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end;
End;
{******************************************************************************
--- Exec ---
******************************************************************************}
var
lastdosexitcode : word;
{$ifdef MSWindows}
procedure exec(const path : pathstr;const comline : comstr);
var
SI: TStartupInfo;
PI: TProcessInformation;
Proc : THandle;
l : DWord;
AppPath,
AppParam : array[0..255] of char;
begin
FillChar(SI, SizeOf(SI), 0);
SI.cb:=SizeOf(SI);
SI.wShowWindow:=1;
Move(Path[1],AppPath,length(Path));
AppPath[Length(Path)]:=#0;
AppParam[0]:='-';
AppParam[1]:=' ';
Move(ComLine[1],AppParam[2],length(Comline));
AppParam[Length(ComLine)+2]:=#0;
if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
begin
DosError:=Last2DosError(GetLastError);
exit;
end
else
DosError:=0;
Proc:=PI.hProcess;
CloseHandle(PI.hThread);
if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
GetExitCodeProcess(Proc,l)
else
l:=$ffffffff;
CloseHandle(Proc);
LastDosExitCode:=l;
end;
{$endif MSWindows}
{$ifdef Linux}
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var
pid,status : longint;
Begin
LastDosExitCode:=0;
pid:=Fork;
if pid=0 then
begin
{The child does the actual exec, and then exits}
Execl(@Path[1],@ComLine[1]);
{If the execve fails, we return an exitvalue of 127, to let it be known}
__exit(127);
end
else
if pid=-1 then {Fork failed}
begin
DosError:=8;
exit
end;
{We're in the parent, let's wait.}
WaitPid(Pid,@Status,0);
LastDosExitCode:=Status; // WaitPid and result-convert
if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
DosError:=0
else
DosError:=8; // perhaps one time give an better error
End;
{$endif Linux}
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure swapvectors;
begin
end;
procedure getcbreak(var breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure setcbreak(breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure getverify(var verify : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure setverify(verify : boolean);
begin
{ !! No Win32 Function !! }
end;
{******************************************************************************
--- Disk ---
******************************************************************************}
{$ifdef Linux]
{
The Diskfree and Disksize functions need a file on the specified drive, since this
is required for the statfs system call.
These filenames are set in drivestr[0..26], and have been preset to :
0 - '.' (default drive - hence current dir is ok.)
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
3 - '/' (C: equivalent of dos is the root partition)
4..26 (can be set by you're own applications)
! Use AddDisk() to Add new drives !
They both return -1 when a failure occurs.
}
Const
FixDriveStr : array[0..3] of pchar=(
'.',
'/fd0/.',
'/fd1/.',
'/.'
);
var
Drives : byte = 4;
var
DriveStr : array[4..26] of pchar;
Procedure AddDisk(const path:string);
begin
if not (DriveStr[Drives]=nil) then
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
GetMem(DriveStr[Drives],length(Path)+1);
StrPCopy(DriveStr[Drives],path);
inc(Drives);
if Drives>26 then
Drives:=4;
end;
Function DiskFree(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
Diskfree:=int64(fs.f_bavail)*int64(fs.f_bsize)
else
Diskfree:=-1;
End;
Function DiskSize(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
Disksize:=int64(fs.f_blocks)*int64(fs.f_bsize)
else
Disksize:=-1;
End;
{$else linux}
function diskfree(drive : byte) : int64;
begin
DiskFree:=SysUtils.DiskFree(drive);
end;
function disksize(drive : byte) : int64;
begin
DiskSize:=SysUtils.DiskSize(drive);
end;
{$endif linux}
{******************************************************************************
--- Findfirst FindNext ---
******************************************************************************}
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
begin
DosError:=SysUtils.FindFirst(Path,Attr,f);
end;
procedure findnext(var f : searchRec);
begin
DosError:=Sysutils.FindNext(f);
end;
Procedure FindClose(Var f: SearchRec);
begin
Sysutils.FindClose(f);
end;
{******************************************************************************
--- File ---
******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;
function fexpand(const path : pathstr) : pathstr;
var
s,pa : string[79];
i,j : longint;
begin
getdir(0,s);
pa:=upper(path);
{ allow slash as backslash }
for i:=1 to length(pa) do
if pa[i]='/' then
pa[i]:='\';
if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
begin
{ we must get the right directory }
getdir(ord(pa[1])-ord('A')+1,s);
if (ord(pa[0])>2) and (pa[3]<>'\') then
if pa[1]=s[1] then
pa:=s+'\'+copy (pa,3,length(pa))
else
pa:=pa[1]+':\'+copy (pa,3,length(pa))
end
else
if pa[1]='\' then
pa:=s[1]+':'+pa
else if s[0]=#3 then
pa:=s+pa
else
pa:=s+'\'+pa;
{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
if length(pa) = 2 then
begin
getdir(byte(pa[1])-64,s);
pa := s;
end;
{First remove all references to '\.\'}
while pos ('\.\',pa)<>0 do
delete (pa,pos('\.\',pa),2);
{Now remove also all references to '\..\' + of course previous dirs..}
repeat
i:=pos('\..\',pa);
if i<>0 then
begin
j:=i-1;
while (j>1) and (pa[j]<>'\') do
dec (j);
if pa[j+1] = ':' then j := 3;
delete (pa,j,i-j+3);
end;
until i=0;
{ Turbo Pascal gets rid of a \.. at the end of the path }
{ Now remove also any reference to '\..' at end of line
+ of course previous dir.. }
i:=pos('\..',pa);
if i<>0 then
begin
if i = length(pa) - 2 then
begin
j:=i-1;
while (j>1) and (pa[j]<>'\') do
dec (j);
delete (pa,j,i-j+3);
end;
pa := pa + '\';
end;
{ Remove End . and \}
if (length(pa)>0) and (pa[length(pa)]='.') then
dec(byte(pa[0]));
{ if only the drive + a '\' is left then the '\' should be left to prevtn the program
accessing the current directory on the drive rather than the root!}
{ if the last char of path = '\' then leave it in as this is what TP does! }
if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
dec(byte(pa[0]));
{ if only a drive is given in path then there should be a '\' at the
end of the string given back }
if length(path) = 2 then pa := pa + '\';
fexpand:=pa;
end;
Function FSearch(path: pathstr; dirlist: string): pathstr;
var
i,p1 : longint;
s : searchrec;
newdir : pathstr;
begin
{ No wildcards allowed in these things }
if (pos('?',path)<>0) or (pos('*',path)<>0) then
fsearch:=''
else
begin
{ allow slash as backslash }
for i:=1 to length(dirlist) do
if dirlist[i]='/' then dirlist[i]:='\';
repeat
p1:=pos(';',dirlist);
if p1=0 then
begin
newdir:=copy(dirlist,1,p1-1);
delete(dirlist,1,p1);
end
else
begin
newdir:=dirlist;
dirlist:='';
end;
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
newdir:=newdir+'\';
findfirst(newdir+path,anyfile,s);
if doserror=0 then
newdir:=newdir+path
else
newdir:='';
until (dirlist='') or (newdir<>'');
fsearch:=newdir;
end;
end;
procedure getftime(var f;var tim : longint);
begin
tim:=FileGetDate(filerec(f).handle);
end;
procedure setftime(var f;time : longint);
begin
{$ifdef linux}
FileSetDate(filerec(f).name,Time);
{$else}
FileSetDate(filerec(f).handle,Time);
{$endif}
end;
{$ifdef linux}
procedure getfattr(var f;var attr : word);
Var
info : tstatbuf;
LinAttr : longint;
Begin
DosError:=0;
if (FStat(filerec(f).handle,info)<>0) then
begin
Attr:=0;
DosError:=3;
exit;
end
else
LinAttr:=Info.st_Mode;
if S_ISDIR(LinAttr) then
Attr:=$10
else
Attr:=$20;
if Access(@filerec(f).name,W_OK)<>0 then
Attr:=Attr or $1;
if (not S_ISDIR(LinAttr)) and (filerec(f).name[0]='.') then
Attr:=Attr or $2;
end;
{$else}
procedure getfattr(var f;var attr : word);
var
l : longint;
begin
l:=FileGetAttr(filerec(f).name);
attr:=l;
end;
{$endif}
procedure setfattr(var f;attr : word);
begin
{$ifdef MSWindows}
FileSetAttr(filerec(f).name,attr);
{$endif}
end;
{******************************************************************************
--- Environment ---
******************************************************************************}
{
The environment is a block of zero terminated strings
terminated by a #0
}
{$ifdef MSWindows}
function GetEnvironmentStrings : pchar;stdcall;
external 'Kernel32.dll' name 'GetEnvironmentStringsA';
function FreeEnvironmentStrings(p : pchar) : boolean;stdcall;
external 'Kernel32.dll' name 'FreeEnvironmentStringsA';
function envcount : longint;
var
hp,p : pchar;
count : longint;
begin
p:=GetEnvironmentStrings;
hp:=p;
count:=0;
while hp^<>#0 do
begin
{ next string entry}
hp:=hp+strlen(hp)+1;
inc(count);
end;
FreeEnvironmentStrings(p);
envcount:=count;
end;
Function EnvStr(index: integer): string;
var
hp,p : pchar;
count,i : longint;
begin
{ envcount takes some time in win32 }
count:=envcount;
{ range checking }
if (index<=0) or (index>count) then
begin
envstr:='';
exit;
end;
p:=GetEnvironmentStrings;
hp:=p;
{ retrive the string with the given index }
for i:=2 to index do
hp:=hp+strlen(hp)+1;
envstr:=strpas(hp);
FreeEnvironmentStrings(p);
end;
Function GetEnv(envvar: string): string;
var
s : string;
i : longint;
hp,p : pchar;
begin
getenv:='';
p:=GetEnvironmentStrings;
hp:=p;
while hp^<>#0 do
begin
s:=strpas(hp);
i:=pos('=',s);
if copy(s,1,i-1)=envvar then
begin
getenv:=copy(s,i+1,length(s)-i);
break;
end;
{ next string entry}
hp:=hp+strlen(hp)+1;
end;
FreeEnvironmentStrings(p);
end;
{$else}
function envcount : longint;
begin
envcount:=0;
end;
Function EnvStr(index: integer): string;
begin
envstr:='';
end;
Function GetEnv(envvar: string): string;
begin
getenv:=GetEnvironmentVariable(envvar);
end;
{$endif}
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
end.
{
$Log$
Revision 1.1 2002-08-16 20:41:32 florian
no message
Revision 1.10 2002/08/12 15:08:39 carl
+ stab register indexes for powerpc (moved from gdb to cpubase)
+ tprocessor enumeration moved to cpuinfo
+ linker in target_info is now a class
* many many updates for m68k (will soon start to compile)
- removed some ifdef or correct them for correct cpu
Revision 1.9 2002/05/18 13:34:07 peter
* readded missing revisions
Revision 1.8 2002/05/16 19:46:36 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
}

321
tests/bench/drystone.pas Normal file
View File

@ -0,0 +1,321 @@
PROGRAM Dhrystone( input, output );
uses
stopuhr;
{
* "DHRYSTONE" Benchmark Program
*
* Version: Mod2/1
* Date: 05/03/86
* Author: Reinhold P. Weicker, CACM Vol 27, No 10, 10/84 pg. 1013
* C version translated from ADA by Rick Richardson
* Every method to preserve ADA-likeness has been used,
* at the expense of C-ness.
* Modula-2 version translated from C by Kevin Northover.
* Again every attempt made to avoid distortions of the original.
* Machine Specifics:
* The LOOPS constant is initially set for 50000 loops.
* If you have a machine with large integers and is
* very fast, please change this number to 500000 to
* get better accuracy.
*
**************************************************************************
*
* The following program contains statements of a high-level programming
* language (Modula-2) in a distribution considered representative:
*
* assignments 53%
* control statements 32%
* procedure, function calls 15%
*
* 100 statements are dynamically executed. The program is balanced with
* respect to the three aspects:
* - statement type
* - operand type (for simple data types)
* - operand access
* operand global, local, parameter, or constant.
*
* The combination of these three aspects is balanced only approximately.
*
* The program does not compute anything meaningfull, but it is
* syntactically and semantically correct.
*
}
{$R- range checking off}
CONST
{ Set LOOPS to specify how many thousand drystones to perform.
LOOPS = 50 will perforum 50,000 drystones. Choose longer for
better precision and for fast machines.
}
LOOPS = 5000; { Use this for slow or 16 bit machines }
Ident1 = 1;
Ident2 = 2;
Ident3 = 3;
Ident4 = 4;
Ident5 = 5;
type integer = longint;
Type Enumeration = INTEGER;
{ TYPE Enumeration = (Ident1, Ident2, Ident3, Ident4, Ident5); }
TYPE OneToThirty = INTEGER;
TYPE OneToFifty = INTEGER;
TYPE CapitalLetter = CHAR;
TYPE String30 = STRING[30]; { ARRAY[0..30] OF CHAR; }
TYPE Array1Dim = ARRAY[0..50] OF INTEGER;
TYPE Array2Dim = ARRAY[0..50,0..50] OF INTEGER;
{ TYPE RecordPtr = ^RecordType; }
RecordType = RECORD
PtrComp : integer;
Discr : Enumeration;
EnumComp : Enumeration;
IntComp : OneToFifty;
StringComp : String30;
END;
{
* Package 1
}
VAR
IntGlob : INTEGER;
BoolGlob : BOOLEAN;
Char1Glob : CHAR;
Char2Glob : CHAR ;
Array1Glob : Array1Dim;
Array2Glob : Array2Dim;
MyRec : array[0..2] of RecordType;
{ PtrGlb : RecordPtr; }
{ PtrGlbNext : RecordPtr; }
Hour, Min, Sec, Hund : word;
TStart, TEnd : real;
CONST
PtrGlb = 1;
PtrGlbNext = 2;
PROCEDURE Proc7(IntParI1, IntParI2 : OneToFifty; VAR IntParOut : OneToFifty);
VAR
IntLoc : OneToFifty;
BEGIN
IntLoc:= IntParI1 + 2;
IntParOut:= IntParI2 + IntLoc;
END ;
PROCEDURE Proc3( var inRecIdx : integer );
BEGIN
IF ( inRecIdx <> 0 ) THEN
inRecIdx := MyRec[PtrGlb].PtrComp
ELSE
IntGlob:= 100;
Proc7( 10, IntGlob, MyRec[PtrGlb].IntComp);
END ;
FUNCTION Func3(EnumParIn : Enumeration) : BOOLEAN;
VAR EnumLoc: Enumeration;
BEGIN
EnumLoc:= EnumParIn;
Func3:= EnumLoc = Ident3;
END ;
PROCEDURE Proc6(EnumParIn : Enumeration; VAR EnumParOut : Enumeration);
BEGIN
EnumParOut:= EnumParIn;
IF (NOT Func3(EnumParIn) ) THEN
EnumParOut:= Ident4;
CASE EnumParIn OF
Ident1: EnumParOut:= Ident1 ;
Ident2: IF (IntGlob > 100) THEN EnumParOut:= Ident1
ELSE EnumParOut:= Ident4;
Ident3: EnumParOut:= Ident2 ;
Ident4: ;
Ident5: EnumParOut:= Ident3;
END;
END ;
PROCEDURE Proc1( inIdx : integer );
var
i : integer;
BEGIN
i := MyRec[inIdx].PtrComp;
MyRec[i] := MyRec[PtrGlb];
MyRec[inIdx].IntComp := 5;
MyRec[i].IntComp:= MyRec[inIdx].IntComp;
MyRec[i].PtrComp:= i;
Proc3( MyRec[i].PtrComp );
IF ( MyRec[i].Discr = Ident1 ) THEN
BEGIN
MyRec[i].IntComp:= 6;
Proc6( MyRec[inIdx].EnumComp, MyRec[i].EnumComp );
MyRec[i].PtrComp:= MyRec[PtrGlb].PtrComp;
Proc7( MyRec[i].IntComp, 10, MyRec[i].IntComp );
END
ELSE
MyRec[inIdx] := MyRec[i];
END;
PROCEDURE Proc2(VAR IntParIO : OneToFifty);
VAR
IntLoc : OneToFifty;
EnumLoc : Enumeration;
BEGIN
IntLoc:= IntParIO + 10;
REPEAT
IF (Char1Glob = 'A') THEN
BEGIN
IntLoc:= IntLoc - 1;
IntParIO:= IntLoc - IntGlob;
EnumLoc:= Ident1;
END;
UNTIL EnumLoc = Ident1;
END ;
PROCEDURE Proc4;
VAR
BoolLoc : BOOLEAN;
BEGIN
BoolLoc:= Char1Glob = 'A';
BoolLoc:= BoolLoc OR BoolGlob;
Char2Glob:= 'B';
END ;
PROCEDURE Proc5;
BEGIN
Char1Glob:= 'A';
BoolGlob:= FALSE;
END ;
PROCEDURE Proc8(VAR Array1Par : Array1Dim; VAR Array2Par : Array2Dim;
IntParI1, IntParI2 : OneToFifty);
VAR
IntLoc : OneToFifty;
IntIndex : OneToFifty;
BEGIN
IntLoc:= IntParI1 + 5;
Array1Par[IntLoc]:= IntParI2;
Array1Par[IntLoc+1]:= Array1Par[IntLoc];
Array1Par[IntLoc+30]:= IntLoc;
FOR IntIndex:= IntLoc TO (IntLoc+1) DO
Array2Par[IntLoc,IntIndex]:= IntLoc;
{ Array2Par[IntLoc,IntLoc-1]:= Array2Par[IntLoc,IntLoc-1] + 1; }
Array2Par[IntLoc+20,IntLoc]:= Array1Par[IntLoc];
IntGlob:= 5;
END ;
FUNCTION Func1(CharPar1, CharPar2 : CapitalLetter) : Enumeration;
VAR
CharLoc1, CharLoc2 : CapitalLetter;
BEGIN
CharLoc1:= CharPar1;
CharLoc2:= CharLoc1;
IF (CharLoc2 <> CharPar2) THEN
Func1:= (Ident1)
ELSE
Func1:= (Ident2);
END ;
FUNCTION Func2(VAR StrParI1, StrParI2 : String30) : BOOLEAN;
VAR
IntLoc : OneToThirty;
CharLoc : CapitalLetter;
BEGIN
IntLoc := 2;
WHILE (IntLoc <= 2) DO
BEGIN
IF (Func1(StrParI1[IntLoc], StrParI2[IntLoc+1]) = Ident1) THEN
BEGIN
CharLoc := 'A';
IntLoc:= IntLoc + 1;
END;
END;
IF (CharLoc >= 'W') AND (CharLoc <= 'Z') THEN IntLoc:= 7;
IF CharLoc = 'X' THEN
Func2:= TRUE
ELSE IF StrParI1 > StrParI2 THEN
BEGIN
IntLoc:= IntLoc + 7;
Func2:= TRUE;
END
ELSE
Func2:= FALSE;
END ;
PROCEDURE Proc0;
VAR
IntLoc1 : OneToFifty;
IntLoc2 : OneToFifty;
IntLoc3 : OneToFifty;
CharLoc : CHAR;
CharIndex : CHAR;
EnumLoc : Enumeration;
String1Loc,
String2Loc : String30;
i,
j : INTEGER;
BEGIN
{
NEW(PtrGlbNext);
NEW(PtrGlb);
}
MyRec[PtrGlb].PtrComp:= PtrGlbNext;
MyRec[PtrGlb].Discr:= Ident1;
MyRec[PtrGlb].EnumComp:= Ident3;
MyRec[PtrGlb].IntComp:= 40;
MyRec[PtrGlb].StringComp := 'DHRYSTONE PROGRAM, SOME STRING';
String1Loc := 'DHRYSTONE PROGRAM, 1''ST STRING';
FOR i := 1 TO LOOPS DO
FOR j := 1 TO 1000 DO
BEGIN
Proc5;
Proc4;
IntLoc1:= 2;
IntLoc2:= 3;
String2Loc := 'DHRYSTONE PROGRAM, 2''ND STRING';
EnumLoc:= Ident2;
BoolGlob:= NOT Func2(String1Loc, String2Loc);
WHILE (IntLoc1 < IntLoc2) DO
BEGIN
IntLoc3 := 5 * IntLoc1 - IntLoc2;
Proc7(IntLoc1, IntLoc2, IntLoc3);
IntLoc1:= IntLoc1 + 1;
END;
Proc8(Array1Glob, Array2Glob, IntLoc1, IntLoc3);
Proc1(PtrGlb);
CharIndex:= 'A';
WHILE CharIndex <= Char2Glob DO
BEGIN
IF (EnumLoc = Func1(CharIndex, 'C')) THEN
Proc6(Ident1, EnumLoc);
{ CharIndex:= SUCC(CharIndex); }
inc(byte(charindex));
END;
IntLoc3:= IntLoc2 * IntLoc1;
IntLoc2:= IntLoc3 DIV IntLoc1;
IntLoc2:= 7 * (IntLoc3 - IntLoc2) - IntLoc1;
Proc2(IntLoc1);
END;
END;
{ The Main Program is trivial }
BEGIN
writeln( 'Start of Dhrystone benchmark' );
start;
Proc0;
stop;
END.

46
tests/bench/timer.pas Normal file
View File

@ -0,0 +1,46 @@
unit timer;
interface
uses
sysutils;
procedure start;
procedure stop;
implementation
var
stime : longint;
function gt : longint;
var
h,m,s,s1000 : word;
begin
decodetime(time,h,m,s,s1000);
gt:=h*3600000+m*60000+s*1000+s1000;
{
gettime(h,m,s,s100);
gt:=h*360000+m*6000+s*100+s100;
}
end;
procedure start;
begin
stime:=gt;
end;
procedure stop;
var
s : longint;
begin
s:=gt-stime;
write(s div 1000,'.',s mod 1000,' Sekunden');
end;
end.

287
tests/bench/whet.pas Normal file
View File

@ -0,0 +1,287 @@
program Whet;
{$IFDEF VirtualPascal}
{$AlignCode+,AlignData+,AlignRec+,Asm-,B-,Cdecl-,D-,Delphi-,Frame+,G4+,I-}
{$Optimise+,OrgName-,P-,Q-,R-,SmartLink+,Speed+,T-,V-,W-,X+,Z-,ZD-}
uses
Dos, Os2Def, Os2Base;
{$ENDIF}
{$IFDEF Speed}
{$B-,D-,I-,L-,O-,Q-,R-,S-,V-,Z-}
uses
Dos, BseDos;
{$ENDIF}
{$IFDEF Speed_Pascal_20}
{$B-,D-,I-,L-,O-,Q-,R-,S-,V-,Z-}
uses
Dos,BseDos,OS2Def;
{$ENDIF}
{$IFDEF VER70}
{$A+,B-,D-,E-,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}
{$M 16384,0,655360}
uses
OpTimer, Dos;
{$ENDIF}
{$IFDEF Delphi}
uses
Dmisc;
{$ENDIF Delphi}
{$IFDEF FPC}
{$ifdef go32v2}
uses
dpmiexcp,Dos;
{$endif go32v2}
{$ifdef win32}
uses
Dos;
{$endif win32}
{$ENDIF FPC}
(**********************************************************************
C Benchmark Double Precision Whetstone (A001)
C
C o This is a LONGREAL*8 version of
C the Whetstone benchmark program.
C o FOR-loop semantics are ANSI-66 compatible.
C o Final measurements are to be made with all
C WRITE statements and FORMAT sttements removed.
C
C**********************************************************************)
{$IFDEF OS2}
function TimeNow : LongInt;
var
Clocks : LongInt;
rc : ApiRet;
begin
rc := DosQuerySysInfo(qsv_Ms_Count, qsv_Ms_Count, Clocks, SizeOf(Clocks));
TimeNow := Clocks;
end;
{$ELSE}
function TimeNow : Double;
var
h,m,s,s100 : word;
begin
gettime(h,m,s,s100);
TimeNow := h*3600+m*60+s+s100*0.01;
end;
{$ENDIF}
TYPE ARRAY4 = ARRAY [1..4] OF DOUBLE;
VAR E1 : ARRAY4;
T, T1, T2 : DOUBLE;
J, K, L : LONGINT;
ptime, time0, time1 : DOUBLE;
PROCEDURE PA (VAR E : ARRAY4);
VAR J1 : LONGINT;
BEGIN
J1 := 0;
REPEAT
E [1] := ( E [1] + E [2] + E [3] - E [4]) * T;
E [2] := ( E [1] + E [2] - E [3] + E [4]) * T;
E [3] := ( E [1] - E [2] + E [3] + E [4]) * T;
E [4] := (-E [1] + E [2] + E [3] + E [4]) / T2;
J1 := J1 + 1;
UNTIL J1 >= 6;
END;
PROCEDURE P0;
BEGIN
E1 [J] := E1 [K]; E1 [K] := E1 [L]; E1 [L] := E1 [J];
END;
PROCEDURE P3 (X,Y : DOUBLE; VAR Z : DOUBLE);
VAR X1, Y1 : DOUBLE;
BEGIN
X1 := X;
Y1 := Y;
X1 := T * (X1 + Y1);
Y1 := T * (X1 + Y1);
Z := (X1 + Y1)/T2;
END;
PROCEDURE POUT (N, J, K : LONGINT; X1, X2, X3, X4 : DOUBLE);
VAR time1 : double;
BEGIN
{
time1 := TimeNow;
WriteLn(time1-time0:6:1,time1-ptime:6,N:6,J:6,K:6,' ',
X1:10,' ', X2:10,' ',X3:10,' ',X4:10);
ptime := time1;
}
END;
PROCEDURE DoIt;
VAR NLoop, I, II, JJ : LONGINT;
N1, N2, N3, N4, N5, N6, N7, N8, N9, N10, N11 : LONGINT;
X1, X2, X3, X4, X, Y, Z : DOUBLE;
BEGIN
time0 := TimeNow;
ptime := time0;
(* The actual benchmark starts here. *)
T := 0.499975;
T1 := 0.50025;
T2 := 2.0;
(* With loopcount NLoop=10, one million Whetstone instructions
will be executed in each major loop.
A major loop is executed 'II' times to increase wall-clock timing accuracy *)
NLoop := 30;
II := 400;
FOR JJ:=1 TO II DO BEGIN
(* Establish the relative loop counts of each module. *)
N1 := 0;
N2 := 12 * NLoop;
N3 := 14 * NLoop;
N4 := 345 * NLoop;
N5 := 0;
N6 := 210 * NLoop;
N7 := 32 * NLoop;
N8 := 899 * NLoop;
N9 := 616 * NLoop;
N10 := 0;
N11 := 93 * NLoop;
(* Module 1: Simple identifiers *)
X1 := 1.0;
X2 := -1.0;
X3 := -1.0;
X4 := -1.0;
FOR I:=1 TO N1 DO BEGIN
X1 := (X1 + X2 + X3 - X4)*T;
X2 := (X1 + X2 - X3 + X4)*T;
X3 := (X1 - X2 + X3 + X4)*T;
X4 := (-X1 + X2 + X3 + X4)*T;
END;
IF (JJ = II) THEN BEGIN
POUT (N1, N1, N1, X1, X2, X3, X4);
END;
(* Module 2: Array elements *)
E1 [1] := 1.0;
E1 [2] := -1.0;
E1 [3] := -1.0;
E1 [4] := -1.0;
FOR I:=1 TO N2 DO BEGIN
E1 [1] := (E1 [1] + E1 [2] + E1 [3] - E1 [4])*T;
E1 [2] := (E1 [1] + E1 [2] - E1 [3] + E1 [4])*T;
E1 [3] := (E1 [1] - E1 [2] + E1 [3] + E1 [4])*T;
E1 [4] := (-E1 [1] + E1 [2] + E1 [3] + E1 [4])*T;
END;
IF (JJ = II) THEN BEGIN
POUT (N2, N3, N2, E1 [1], E1 [2], E1 [3], E1 [4]);
END;
(* Module 3: Array as parameter *)
FOR I:=1 TO N3 DO BEGIN
PA (E1);
END;
IF (JJ = II) THEN BEGIN
POUT(N3, N2, N2, E1 [1], E1 [2], E1 [3], E1 [4]);
END;
(* Module 4: Conditional jumps *)
J := 1;
FOR I:=1 TO N4 DO BEGIN
IF (J <> 1) THEN J := 3 ELSE J := 2;
IF (J <= 2) THEN J := 1 ELSE J := 0;
IF (J >= 1) THEN J := 0 ELSE J := 1;
END;
IF (JJ = II) THEN BEGIN
POUT (N4, J, J, X1, X2, X3, X4)
END;
(* Module 5: Omitted; Module 6: Integer arithmetic *)
J := 1;
K := 2;
L := 3;
FOR I:=1 TO N6 DO BEGIN
J := J * (K-J) * (L-K);
K := L * K - (L-J) * K;
L := (L - K) * (K + J);
E1 [L-1] := (J + K + L);
E1 [K-1] := (J * K * L);
END;
IF (JJ = II) THEN BEGIN
POUT (N6, J, K, E1 [1], E1 [2], E1 [3], E1 [4]);
END;
(* Module 7: Trigonometric functions *)
X := 0.5;
Y := 0.5;
FOR I:=1 TO N7 DO BEGIN
X:=T*arctan(T2*sin(X)*cos(X)/(cos(X+Y)+cos(X-Y)-1.0));
Y:=T*arctan(T2*sin(Y)*cos(Y)/(cos(X+Y)+cos(X-Y)-1.0));
END;
IF (JJ = II) THEN BEGIN
POUT (N7, J, K, X, X, Y, Y);
END;
(* Module 8: Procedure calls *)
X := 1.0;
Y := 1.0;
Z := 1.0;
FOR I:=1 TO N8 DO BEGIN
P3 (X,Y,Z);
END;
IF (JJ = II) THEN BEGIN
POUT (N8, J, K, X, Y, Z, Z);
END;
(* Module 9: Array references *)
J := 1;
K := 2;
L := 3;
E1 [1] := 1.0;
E1 [2] := 2.0;
E1 [3] := 3.0;
FOR I:=1 TO N9 DO BEGIN
P0;
END;
IF (JJ = II) THEN BEGIN
POUT (N9, J, K, E1 [1], E1 [2], E1 [3], E1 [4])
END;
(* Module 10: Integer arithmetic *)
J := 2;
K := 3;
FOR I:=1 TO N10 DO BEGIN
J := J + K;
K := J + K;
J := K - J;
K := K - J - J;
END;
IF (JJ = II) THEN BEGIN
POUT (N10, J, K, X1, X2, X3, X4)
END;
(* Module 11: Standard functions *)
X := 0.75;
FOR I:=1 TO N11 DO BEGIN
X := sqrt (exp (ln (X)/T1))
// x:=sqrt(x);
END;
IF (JJ = II) THEN BEGIN
POUT (N11, J, K, X, X, X, X)
END;
(* THIS IS THE END OF THE MAJOR LOOP. *)
END;
(* Stop benchmark timing at this point. *)
time1 := TimeNow;
(*----------------------------------------------------------------
Performance in Whetstone KIP's per second is given by
(100*NLoop*II)/TIME
where TIME is in seconds.
--------------------------------------------------------------------*)
WriteLn;
WriteLn ('Double Whetstone KIPS ',
(TRUNC ((100.0 * NLoop * II) /
((time1 - time0)/1000))));
WriteLn ('Whetstone MIPS ',
1.0*NLoop*II /((1.0*time1 - 1.0*time0)/1000 * 10):12:2);
END;
BEGIN
DoIt;
END.