no message

tests/bench/dmisc.pas

@@ -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
+
+}

tests/bench/drystone.pas

@@ -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.
+

tests/bench/timer.pas

@@ -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.

tests/bench/whet.pas

@@ -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.