* GetMsCount added, platform independent routines moved to single include file

rtl/amiga/dos.pp

@@ -33,9 +33,6 @@ Interface
 
 {$I os.inc}
 
-Const
-  FileNameLen = 255;
-
 type
   SearchRec = Packed Record
     { watch out this is correctly aligned for all processors }
@@ -50,17 +47,19 @@ type
     Name : String[255]; {name of found file}
   End;
 
-  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;
-
 {$i dosh.inc}
 
 implementation
 
+{$DEFINE HAS_GETCBREAK}
+{$DEFINE HAS_SETCBREAK}
+
+{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
+{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
+
+{$I dos.inc}
+
 const
   DaysPerMonth :  Array[1..12] of ShortInt =
 (031,028,031,030,031,030,031,031,030,031,030,031);
@@ -611,38 +610,6 @@ begin
 end;
 
 
-Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
-var
-  cd : pClockData;
-Begin
-  New(cd);
-  Amiga2Date(SecsPast,cd);
-  Dt.sec   := cd^.sec;
-  Dt.min   := cd^.min;
-  Dt.hour  := cd^.hour;
-  Dt.day   := cd^.mday;
-  Dt.month := cd^.month;
-  Dt.year  := cd^.year;
-  Dispose(cd);
-End;
-
-Function DtToAmiga(DT: DateTime): LongInt;
-var
-  cd : pClockData;
-  temp : Longint;
-Begin
-  New(cd);
-  cd^.sec   := Dt.sec;
-  cd^.min   := Dt.min;
-  cd^.hour  := Dt.hour;
-  cd^.mday  := Dt.day;
-  cd^.month := Dt.month;
-  cd^.year  := Dt.year;
-  temp := Date2Amiga(cd);
-  Dispose(cd);
-  DtToAmiga := temp;
-end;
-
 Function SetProtection(const name: string; mask:longint): longint;
  var
   buffer : array[0..255] of char;
@@ -664,7 +631,8 @@ Function SetProtection(const name: string; mask:longint): longint;
 
 Function IsLeapYear(Source : Word) : Boolean;
 Begin
-  If (Source Mod 4 = 0) Then
+  If (Source mod 400 = 0) or ((Source mod 4 = 0) and (Source mod 100 <> 0))
+   Then
     IsLeapYear := True
   Else
     IsLeapYear := False;
@@ -750,41 +718,6 @@ End;
 
 
 
-
-
-{******************************************************************************
-                           --- Dos Interrupt ---
-******************************************************************************}
-
-Procedure Intr (intno: byte; var regs: registers);
-  Begin
-  { Does not apply to Linux - not implemented }
-  End;
-
-
-Procedure SwapVectors;
-  Begin
-  { Does not apply to Linux - Do Nothing }
-  End;
-
-
-Procedure msdos(var regs : registers);
-  Begin
-  { ! Not implemented in Linux ! }
-  End;
-
-
-Procedure getintvec(intno : byte;var vector : pointer);
-  Begin
-  { ! Not implemented in Linux ! }
-  End;
-
-
-Procedure setintvec(intno : byte;vector : pointer);
-  Begin
-  { ! Not implemented in Linux ! }
-  End;
-
 {******************************************************************************
                         --- Info / Date / Time ---
 ******************************************************************************}
@@ -839,31 +772,11 @@ Procedure SetTime(Hour, Minute, Second, Sec100: Word);
   { !! }
   End;
 
-Procedure unpacktime(p : longint;var t : datetime);
-Begin
-  AmigaToDt(p,t);
-End;
-
-
-Procedure packtime(var t : datetime;var p : longint);
-Begin
-  p := DtToAmiga(t);
-end;
-
-
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  LastDosExitCode: word;
-
-
 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
   var
    p : string;
@@ -903,12 +816,6 @@ Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
   End;
 
 
-Function DosExitCode: Word;
-  Begin
-    DosExitCode:=LastdosExitCode;
-  End;
-
-
   Procedure GetCBreak(Var BreakValue: Boolean);
   Begin
    breakvalue := system.BreakOn;
@@ -921,16 +828,6 @@ Function DosExitCode: Word;
   End;
 
 
-  Procedure GetVerify(Var Verify: Boolean);
-   Begin
-     verify:=true;
-   End;
-
-
- Procedure SetVerify(Verify: Boolean);
-  Begin
-  End;
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -1188,35 +1085,7 @@ End;
                                --- File ---
 ******************************************************************************}
 
-Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
-var
-  I: Word;
-begin
-  { allow backslash as slash }
-  for i:=1 to length(path) do
-    if path[i]='\' then path[i]:='/';
-
-  I := Length(Path);
-  while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':'))
-     do Dec(I);
-  if Path[I] = '/' then
-     dir := Copy(Path, 0, I)
-  else dir := Copy(Path,0,I);
-
-  if Length(Path) > Length(dir) then
-      name := Copy(Path, I + 1, Length(Path)-I)
-  else
-      name := '';
-  { Remove extension }
-  if pos('.',name) <> 0 then
-     delete(name,pos('.',name),length(name));
-
-  I := Pos('.',Path);
-  if I > 0 then
-     ext := Copy(Path,I,Length(Path)-(I-1))
-     else ext := '';
-end;
-
+(*
 Function FExpand(Path: PathStr): PathStr;
 var
     FLock  : BPTR;
@@ -1266,6 +1135,7 @@ begin
        end;
     end else FExpand := '';
 end;
+*)
 
 
    Function  fsearch(path : pathstr;dirlist : string) : pathstr;
@@ -1533,15 +1403,6 @@ begin
 end;
 
 
-{******************************************************************************
-                             --- Not Supported ---
-******************************************************************************}
-
-Procedure keep(exitcode : word);
-  Begin
-  { ! Not implemented in Linux ! }
-  End;
-
 procedure AddDevice(str : String);
 begin
     inc(numberofdevices);
@@ -1612,7 +1473,10 @@ End.
 
 {
   $Log$
-  Revision 1.8  2004-02-17 17:37:25  daniel
+  Revision 1.9  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.8  2004/02/17 17:37:25  daniel
     * Enable threadvars again
 
   Revision 1.7  2004/02/16 22:16:55  hajny

rtl/beos/dos.pp

@@ -20,9 +20,6 @@ Interface
 
 {$goto on}
 
-Const
-  FileNameLen=255;
-
 Type
   SearchRec = packed Record
   {Fill : array[1..21] of byte;  Fill replaced with below}
@@ -39,13 +36,6 @@ Type
     SearchDir  : String[FileNameLen]; { path we are searching in }
   End;
 
-  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;
-
 {$i dosh.inc}
 
 Procedure AddDisk(const path:string);
@@ -53,8 +43,10 @@ Procedure AddDisk(const path:string);
 Implementation
 
 Uses
-  Strings,posix;
+  strings,posix;
 
+(* Potentially needed FPC_FEXPAND_* defines should be defined here. *)
+{$I dos.inc}
 
   { Used by AddDisk(), DiskFree() and DiskSize() }
 const
@@ -111,7 +103,7 @@ begin
 end;
 
 
-{$i dos.inc}    { include OS specific stuff }
+{$i dos_beos.inc}    { include OS specific stuff }
 
 
 
@@ -251,25 +243,6 @@ Begin
 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
-  t.sec:=(p and 31) shl 1;
-  t.min:=(p shr 5) and 63;
-  t.hour:=(p shr 11) and 31;
-  t.day:=(p shr 16) and 31;
-  t.month:=(p shr 21) and 15;
-  t.year:=(p shr 25)+1980;
-End;
-
-
 Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
 Begin
   EpochToLocal(SecsPast,dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
@@ -281,14 +254,6 @@ End;
                                --- Exec ---
 ******************************************************************************}
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  LastDosExitCode: word;
-
-
 Function  InternalWaitProcess(Pid:pid_t):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
 var     r,s     : cint;
 begin
@@ -376,11 +341,6 @@ Begin
   if (LastDosExitCode>=0) and (LastDosExitCode<>127) then DosError:=0 else
      DosError:=8; // perhaps one time give an better error
 End;
-
-Function DosExitCode: Word;
-Begin
-  DosExitCode:=LastDosExitCode;
-End;
 {$ENDIF}
 
 
@@ -650,44 +610,6 @@ End;
                                --- File ---
 ******************************************************************************}
 
-Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
-Var
-  DotPos,SlashPos,i : longint;
-Begin
-  SlashPos:=0;
-  DotPos:=256;
-  i:=Length(Path);
-  While (i>0) and (SlashPos=0) Do
-   Begin
-     If (DotPos=256) and (Path[i]='.') Then
-      begin
-        DotPos:=i;
-      end;
-     If (Path[i]='/') Then
-      SlashPos:=i;
-     Dec(i);
-   End;
-  Ext:=Copy(Path,DotPos,255);
-  Dir:=Copy(Path,1,SlashPos);
-  Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
-End;
-
-
-
-{
-function FExpand (const Path: PathStr): PathStr;
-- declared in fexpand.inc
-}
-(*
-{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
-*)
-const
-  LFNSupport = true;
-  FileNameCaseSensitive = true;
-
-{$I fexpand.inc}
-
-
 
 Function FSearch(const path:pathstr;dirlist:string):pathstr;
 {
@@ -866,52 +788,6 @@ end;
 
 
 
-{******************************************************************************
-                      --- Do Nothing Procedures/Functions ---
-******************************************************************************}
-
-Procedure Intr (intno: byte; var regs: registers);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure msdos(var regs : registers);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure getintvec(intno : byte;var vector : pointer);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure setintvec(intno : byte;vector : pointer);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure SwapVectors;
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure keep(exitcode : word);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
 Procedure setftime(var f; time : longint);
 Begin
   {! No POSIX equivalent !}
@@ -926,34 +802,6 @@ End;
 
 
 
-Procedure GetCBreak(Var BreakValue: Boolean);
-Begin
-{! No POSIX equivalent !}
-  breakvalue:=true
-End;
-
-
-
-Procedure SetCBreak(BreakValue: Boolean);
-Begin
-  {! No POSIX equivalent !}
-End;
-
-
-
-Procedure GetVerify(Var Verify: Boolean);
-Begin
-  {! No POSIX equivalent !}
-  Verify:=true;
-End;
-
-
-
-Procedure SetVerify(Verify: Boolean);
-Begin
-  {! No POSIX equivalent !}
-End;
-
 { Include timezone routines }
 {$i timezone.inc}
 
@@ -969,7 +817,10 @@ finalization
 end.
 {
   $Log$
-  Revision 1.9  2004-02-17 17:37:26  daniel
+  Revision 1.10  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.9  2004/02/17 17:37:26  daniel
     * Enable threadvars again
 
   Revision 1.8  2004/02/16 22:16:57  hajny

rtl/emx/dos.pas

@@ -30,16 +30,13 @@ interface
 
 uses    Strings, DosCalls;
 
-Const 
-  FileNameLen = 255;
-  
 Type
   {Search record which is used by findfirst and findnext:}
   searchrec=record
     case boolean of
-    false: (handle:longint;     {Used in os_OS2 mode}
+    false: (handle:THandle;     {Used in os_OS2 mode}
             FStat:PFileFindBuf3;
-            fill2:array[1..21-SizeOf(longint)-SizeOf(pointer)] of byte;
+            fill2:array[1..21-SizeOf(THandle)-SizeOf(pointer)] of byte;
             attr2:byte;
             time2:longint;
             size2:longint;
@@ -51,16 +48,6 @@ Type
             name:string);       {Filenames can be long in OS/2!}
   end;
 
-
-   {Data structure for the registers needed by msdos and intr:}
-  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;
-
 {$i dosh.inc}
 
         {Flags for the exec procedure:
@@ -127,13 +114,24 @@ var
 
 implementation
 
+{$DEFINE HAS_INTR}
+{$DEFINE HAS_SETVERIFY}
+{$DEFINE HAS_GETVERIFY}
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+const
+    LFNSupport = true;
+
+{$I dos.inc}
+
 
 {$ifdef HASTHREADVAR}
 threadvar
 {$else HASTHREADVAR}
 var
 {$endif HASTHREADVAR}
-  LastDosExitCode: longint;
   LastSR: SearchRec;
 
 var
@@ -218,6 +216,7 @@ begin
         end;
 end;
 
+
 procedure GetFTime (var F; var Time: longint); assembler;
 asm
     pushl %ebx
@@ -244,6 +243,7 @@ asm
     popl %ebx
 end {['eax', 'ecx', 'edx']};
 
+
 procedure SetFTime (var F; Time: longint);
 
 var FStat: TFileStatus3;
@@ -281,16 +281,8 @@ begin
         end ['eax', 'ecx', 'edx'];
 end;
 
-procedure msdos(var regs:registers);
-
-{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
-
-begin
-   if os_mode in [osDPMI,osDOS] then
-     intr($21,regs);
-end;
 
-procedure intr(intno:byte;var regs:registers);
+procedure Intr (IntNo: byte; var Regs: Registers);
 
 {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
 
@@ -497,13 +489,6 @@ begin
 end;
 
 
-function DosExitCode: word;
-
-begin
-  DosExitCode := LastDosExitCode and $FFFF;
-end;
-
-
 function dosversion:word;assembler;
 
 {Returns DOS version in DOS and OS/2 version in OS/2}
@@ -512,6 +497,7 @@ asm
     call syscall
 end ['eax'];
 
+
 procedure GetDate (var Year, Month, MDay, WDay: word);
 
 begin
@@ -533,8 +519,8 @@ begin
     end ['eax', 'ecx', 'edx'];
 end;
 
-{$asmmode intel}
 
+{$asmmode intel}
 procedure SetDate (Year, Month, Day: word);
 var DT: TDateTime;
 begin
@@ -555,9 +541,9 @@ begin
             call syscall
         end ['eax', 'ecx', 'edx'];
 end;
-
 {$asmmode att}
 
+
 procedure GetTime (var Hour, Minute, Second, Sec100: word);
 {$IFDEF REGCALL}
 begin
@@ -587,6 +573,7 @@ end;
 end {['eax', 'ecx', 'edx']};
 {$ENDIF REGCALL}
 
+
 {$asmmode intel}
 procedure SetTime (Hour, Minute, Second, Sec100: word);
 var DT: TDateTime;
@@ -613,24 +600,6 @@ end;
 
 {$asmmode att}
 
-procedure getcbreak(var breakvalue:boolean);
-
-begin
-  breakvalue := True;
-end;
-
-procedure setcbreak(breakvalue:boolean);
-
-begin
-{! Do not use in OS/2. Also not recommended in DOS. Use
-       signal handling instead.
-    asm
-        movb BreakValue,%dl
-        movw $0x3301,%ax
-        call syscall
-    end ['eax', 'edx'];
-}
-end;
 
 procedure getverify(var verify:boolean);
 
@@ -830,7 +799,7 @@ begin
     if os_mode = osOS2 then
     begin
       New (F.FStat);
-      F.Handle := longint ($FFFFFFFF);
+      F.Handle := THandle ($FFFFFFFF);
       Count := 1;
       DosError := integer (DosFindFirst (Path, F.Handle,
                      Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
@@ -877,25 +846,23 @@ begin
     DosSearchRec2SearchRec (F);
 end;
 
+
 procedure FindClose (var F: SearchRec);
 begin
     if os_mode = osOS2 then
     begin
-  if F.Handle <> $FFFFFFFF then DosError := DosFindClose (F.Handle);
+  if F.Handle <> THandle ($FFFFFFFF) then DosError := DosFindClose (F.Handle);
   Dispose (F.FStat);
 end;
 end;
 
-procedure swapvectors;
-{For TP compatibility, this exists.}
-begin
-end;
 
 function envcount:longint;assembler;
 asm
     movl envc,%eax
 end ['EAX'];
 
+
 function envstr(index : longint) : string;
 
 var hp:Pchar;
@@ -910,6 +877,7 @@ begin
     envstr:=strpas(hp);
 end;
 
+
 function GetEnvPChar (EnvVar: string): PChar;
 (* The assembler version is more than three times as fast as Pascal. *)
 var
@@ -969,108 +937,12 @@ begin
 end;
 {$ASMMODE ATT}
 
+
 function GetEnv (EnvVar: string): string;
 begin
  GetEnv := StrPas (GetEnvPChar (EnvVar));
 end;
 
-procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
-                 var ext:extstr);
-
-var p1,i : longint;
-    dotpos : integer;
-
-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 }
-   Ext:='';
-   i:=Length(Path);
-   DotPos:=256;
-   While (i>0) Do
-     Begin
-       If (Path[i]='.') Then
-         begin
-           DotPos:=i;
-           break;
-         end;
-       Dec(i);
-     end;
-   Ext:=Copy(Path,DotPos,255);
-   Name:=Copy(Path,1,DotPos - 1);
-end;
-
-(*
-function FExpand (const Path: PathStr): PathStr;
-- declared in fexpand.inc
-*)
-
-{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
-{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
-
-const
-    LFNSupport = true;
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_DRIVES}
-{$UNDEF FPC_FEXPAND_UNC}
-
-procedure PackTime (var T: DateTime; var P: longint);
-
-var zs:longint;
-
-begin
-    P := -1980;
-    P := P + T.Year and 127;
-    P := P shl 4;
-    P := P + T.Month;
-    P := P shl 5;
-    P := P + T.Day;
-    P := P shl 16;
-    zs:= T.hour;
-    zs:= zs shl 6;
-    zs:= zs + T.Min;
-    zs:= zs shl 5;
-    zs:= zs + T.Sec div 2;
-    P := P + (zs and $ffff);
-end;
-
-procedure unpacktime (P: longint; var T: DateTime);
-
-begin
-    T.Sec := (P and 31) * 2;
-    P := P shr 5;
-    T.Min := P and 63;
-    P := P shr 6;
-    T.Hour := P and 31;
-    P := P shr 5;
-    T.Day := P and 31;
-    P := P shr 5;
-    T.Month := P and 15;
-    P := P shr 4;
-    T.Year := P + 1980;
-end;
 
 procedure getfattr(var f;var attr : word);
  { Under EMX, this routine requires     }
@@ -1102,6 +974,7 @@ begin
  end ['eax', 'ecx', 'edx'];
 end;
 
+
 procedure setfattr(var f;attr : word);
  { Under EMX, this routine requires     }
  { the expanded path specification      }
@@ -1195,28 +1068,6 @@ var
                              --- 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;
-
-function  GetShortName(var p : String) : boolean;
-begin
-  GetShortName:=true;
-end;
-
-function  GetLongName(var p : String) : boolean;
-begin
-  GetLongName:=true;
-end;
-
 
 
 begin
@@ -1229,7 +1080,10 @@ end.
 
 {
   $Log$
-  Revision 1.15  2004-03-21 20:35:24  hajny
+  Revision 1.16  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.15  2004/03/21 20:35:24  hajny
     * Exec cleanup
 
   Revision 1.14  2004/03/08 22:31:00  hajny

rtl/go32v2/dos.pp

@@ -20,9 +20,6 @@ interface
 Uses
   Go32;
 
-Const
-  FileNameLen = 255;
-
 Type
   searchrec = packed record
      fill : array[1..21] of byte;
@@ -33,6 +30,7 @@ Type
      name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
   end;
 
+{$DEFINE HAS_REGISTERS}
   Registers = Go32.Registers;
 
 {$i dosh.inc}
@@ -42,6 +40,21 @@ implementation
 uses
   strings;
 
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_INTR}
+{$DEFINE HAS_SETCBREAK}
+{$DEFINE HAS_GETCBREAK}
+{$DEFINE HAS_SETVERIFY}
+{$DEFINE HAS_GETVERIFY}
+{$DEFINE HAS_SWAPVECTORS}
+{$DEFINE HAS_GETSHORTNAME}
+{$DEFINE HAS_GETLONGNAME}
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+{$I dos.inc}
+
 {******************************************************************************
                            --- Dos Interrupt ---
 ******************************************************************************}
@@ -82,12 +95,6 @@ begin
 end;
 
 
-procedure msdos(var regs : registers);
-begin
-  intr($21,regs);
-end;
-
-
 {******************************************************************************
                         --- Info / Date / Time ---
 ******************************************************************************}
@@ -143,37 +150,16 @@ begin
 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;
+function GetMsCount: int64;
+begin
+  GetMsCount := MemL [$40:$6c] * 55;
+end;
 
 
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  lastdosexitcode : word;
-
 procedure exec(const path : pathstr;const comline : comstr);
 type
   realptr = packed record
@@ -296,12 +282,6 @@ begin
 end;
 
 
-function dosexitcode : word;
-begin
-  dosexitcode:=lastdosexitcode;
-end;
-
-
 procedure getcbreak(var breakvalue : boolean);
 begin
   dosregs.ax:=$3300;
@@ -640,78 +620,6 @@ end;
                                --- File ---
 ******************************************************************************}
 
-procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
-var
-   dotpos,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 }
-  if LFNSupport then
-    begin
-       Ext:='';
-       i:=Length(Path);
-       DotPos:=256;
-       While (i>0) Do
-         Begin
-            If (Path[i]='.') Then
-              begin
-                 DotPos:=i;
-                 break;
-              end;
-            Dec(i);
-         end;
-       Ext:=Copy(Path,DotPos,255);
-       Name:=Copy(Path,1,DotPos - 1);
-    end
-  else
-    begin
-       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;
-end;
-
-
-(*
-function FExpand (const Path: PathStr): PathStr;
-- declared in fexpand.inc
-*)
-
-{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
-{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_DRIVES}
-{$UNDEF FPC_FEXPAND_UNC}
-
 
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
@@ -930,27 +838,13 @@ begin
 end;
 
 
-{******************************************************************************
-                             --- 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.21  2004-02-17 17:37:26  daniel
+  Revision 1.22  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.21  2004/02/17 17:37:26  daniel
     * Enable threadvars again
 
   Revision 1.20  2004/02/16 22:16:59  hajny

rtl/inc/dos.inc

@@ -29,7 +29,6 @@ var
  {$ENDIF HASTHREADVAR}
   LastDosExitCode: longint;
 
-
 function DosExitCode: word;
 begin
   if LastDosExitCode > high (word) then
@@ -108,16 +107,25 @@ end;
 
 
 {$IFNDEF HAS_GETVERIFY}
+var
+  VerifyValue: boolean;
+
 procedure GetVerify (var Verify: boolean);
 begin
-  Verify := true;
+  Verify := VerifyValue;
 end;
 {$ENDIF HAS_GETVERIFY}
 
 
 {$IFNDEF HAS_SETVERIFY}
+ {$IFDEF HAS_GETVERIFY}
+var
+  VerifyValue: boolean;
+ {$ENDIF HAS_GETVERIFY}
+
 procedure SetVerify (Verify: boolean);
 begin
+  VerifyValue := Verify;
 end;
 {$ENDIF HAS_SETVERIFY}
 
@@ -290,7 +298,10 @@ end;
 
 {
   $Log$
-  Revision 1.1  2004-11-28 12:33:35  hajny
+  Revision 1.2  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.1  2004/11/28 12:33:35  hajny
     * common implementation of platform independent functions for unit Dos
 
 

rtl/macos/dos.pp

@@ -19,10 +19,6 @@ Uses
   macostp;
   
 
-Const
-  {Max PathName Length for files}
-  FileNameLen=255;
-
 Type
     SearchRec = packed record
         Attr: Byte;       {attribute of found file}
@@ -65,6 +61,19 @@ Uses
   macutils,
   unixutil {for FNMatch};
 
+{$UNDEF USE_FEXPAND_INC}
+
+{$IFNDEF USE_FEXPAND_INC}
+ {$DEFINE HAS_FEXPAND}
+{$ENDIF USE_FEXPAND_INC}
+
+{$DEFINE FPC_FEXPAND_VOLUMES}
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
+{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
+
+{$I dos.inc}
+
+
 function MacTimeToDosPackedTime(macfiletime: UInt32): Longint;
 var
   mdt: DateTimeRec; {Mac OS datastructure}
@@ -125,21 +134,6 @@ begin
   sec100 := 0;
 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
-  t.sec:=(p and 31) shl 1;
-  t.min:=(p shr 5) and 63;
-  t.hour:=(p shr 11) and 31;
-  t.day:=(p shr 16) and 31;
-  t.month:=(p shr 21) and 15;
-  t.year:=(p shr 25)+1980;
-End;
-
 Procedure SetDate(Year, Month, Day: Word);
 
   var
@@ -277,13 +271,6 @@ begin
   ExecuteToolserverScript:= err;
 end;
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  laststatuscode : longint;
-
 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
 var
   s: AnsiString;
@@ -294,13 +281,13 @@ Begin
   {Make ToolServers working directory in sync with our working directory}
   PathArgToFullPath(':', wdpath);
   wdpath:= 'Directory ' + wdpath;
-  err:= ExecuteToolserverScript(PChar(wdpath), laststatuscode);
+  err:= ExecuteToolserverScript(PChar(wdpath), LastDosExitCode);
     {TODO Only change path when actually needed. But this requires some 
      change counter to be incremented each time wd is changed. }
 
   s:= path + ' ' + comline;
   
-  err:= ExecuteToolserverScript(PChar(s), laststatuscode);
+  err:= ExecuteToolserverScript(PChar(s), LastDosExitCode);
   if err = afpItemNotFound then
     DosError := 900
   else
@@ -308,21 +295,6 @@ Begin
   //TODO Better dos error codes
 End;
 
-Function DosExitCode: Word;
-var
-  clippedstatus: Word;
-Begin
-  if laststatuscode <> 0 then
-    begin
-      {MPW status might be 24 bits}
-      clippedstatus := laststatuscode and $ffff;
-      if clippedstatus = 0 then
-        clippedstatus:= 1;
-      DosExitCode:= clippedstatus;
-    end
-  else
-    DosExitCode := 0;  
-End;
 
 {******************************************************************************
                                --- Disk ---
@@ -785,26 +757,7 @@ End;
   end;
 
 
-{$UNDEF USE_FEXPAND_INC}
-
-{$IFDEF USE_FEXPAND_INC}
-
-
-{$DEFINE FPC_FEXPAND_VOLUMES}
-{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
-{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
-
-{ TODO A lot of issues before this works}
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_VOLUMES}
-{$UNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
-{$UNDEF FPC_FEXPAND_DRIVESEP_IS_ROOT}
-
-
-
-{$ELSE}
+{$IFNDEF USE_FEXPAND_INC}
 
 { TODO nonexisting dirs in path's doesnt work (nonexisting files do work)
        example: Writeln('FExpand on :nisse:kalle : ', FExpand(':nisse:kalle')); }
@@ -817,29 +770,8 @@ End;
     FExpand:= fullpath;
   end;
 
-{$ENDIF}
-
-  procedure FSplit (path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
+{$ENDIF USE_FEXPAND_INC}
 
-  var
-    dotPos,colonPos,i : longint;
-  
-  begin
-    colonPos:=0;
-    dotPos:=256;
-    i:=Length(path);
-    while (i>0) and (colonPos=0) Do
-      begin
-        If (dotPos=256) and (path[i]='.') Then
-          dotPos:=i;
-        If (path[i]=':') Then
-          colonPos:=i;
-        Dec(i);
-      end;
-    ext:=Copy(path,dotPos,255);
-    dir:=Copy(path,1,colonPos);
-    name:=Copy(path,colonPos + 1,dotPos - colonPos - 1);
-  end;
 
   procedure GetFTime (var f ; var time: longint);
 
@@ -998,64 +930,28 @@ Begin
    GetEnv:=StrPas(p);
 End;
 
-{******************************************************************************
-                      --- Do Nothing Procedures/Functions ---
-******************************************************************************}
-
-Procedure getintvec(intno : byte;var vector : pointer);
-Begin
-  {! No MacOS equivalent !}
-End;
-
-Procedure setintvec(intno : byte;vector : pointer);
-Begin
-  {! No MacOS equivalent !}
-End;
-
-Procedure SwapVectors;
-Begin
-  {! No MacOS equivalent !}
-End;
-
-Procedure Keep(exitcode : word);
-Begin
-  {! No MacOS equivalent !}
-End;
-
+{
 Procedure GetCBreak(Var BreakValue: Boolean);
 Begin
-  {! Might be implemented in future on MacOS to handle Cmd-. (period) key press}
-  breakvalue:=true
+--  Might be implemented in future on MacOS to handle Cmd-. (period) key press
 End;
 
 Procedure SetCBreak(BreakValue: Boolean);
 Begin
-  {! Might be implemented in future on MacOS to handle Cmd-. (period) key press}
+--  Might be implemented in future on MacOS to handle Cmd-. (period) key press
 End;
 
 Procedure GetVerify(Var Verify: Boolean);
 Begin
-  {! Might be implemented in future on MacOS}
-  Verify:=true;
+--  Might be implemented in future on MacOS
 End;
 
 Procedure SetVerify(Verify: Boolean);
 Begin
-  {! Might be implemented in future on MacOS}
+--   Might be implemented in future on MacOS
 End;
+}
 
-function  GetShortName(var p : String) : boolean;
-
-begin
-  { short=long under MacOS}
- GetShortName:=True;
-end;
-
-function  GetLongName(var p : String) : boolean;
-begin
-  { short=long under MacOS}
- GetLongName:=True;
-end;
 
 {******************************************************************************
                             --- Initialization ---

rtl/morphos/dos.pp

@@ -32,49 +32,6 @@ unit Dos;
 
 interface
 
-const
-  {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
-  ComStr  = String[255];  { size increased to be more compatible with Unix}
-  PathStr = String[255];  { size increased to be more compatible with Unix}
-  DirStr  = String[255];  { size increased to be more compatible with Unix}
-  NameStr = String[255];  { size increased to be more compatible with Unix}
-  ExtStr  = String[255];  { size increased to be more compatible with Unix}
-
-
-{
-  filerec.inc contains the definition of the filerec.
-  textrec.inc contains the definition of the textrec.
-  It is in a separate file to make it available in other units without
-  having to use the DOS unit for it.
-}
-{$i filerec.inc}
-{$i textrec.inc}
-
-
 type
   SearchRec = Packed Record
     { watch out this is correctly aligned for all processors }
@@ -89,80 +46,19 @@ type
     Name : String[255]; {name of found file}
   End;
 
+{$I dosh.inc}
 
-  DateTime = packed record
-    Year : Word;
-    Month: Word;
-    Day  : Word;
-    Hour : Word;
-    Min  : Word;
-    Sec  : Word;
-  End;
-
-  { Some ugly x86 registers... }
-  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;
+implementation
 
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_GETCBREAK}
+{$DEFINE HAS_SETSBREAK}
 
-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 SetDate(year,month,day: word);
-Procedure SetTime(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) : longint;
-Function  DiskSize(drive: byte) : longint;
-Procedure FindFirst(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 time: 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);
-
+{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
+{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
+{$I dos.inc}
 
-implementation
 
 { * include MorphOS specific functions & definitions * }
 
@@ -212,38 +108,6 @@ begin
   BSTR2STRING:=Pointer(Longint(BADDR(s))+1);
 end;
 
-Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
-var
-  cd : pClockData;
-Begin
-  New(cd);
-  Amiga2Date(SecsPast,cd);
-  Dt.sec   := cd^.sec;
-  Dt.min   := cd^.min;
-  Dt.hour  := cd^.hour;
-  Dt.day   := cd^.mday;
-  Dt.month := cd^.month;
-  Dt.year  := cd^.year;
-  Dispose(cd);
-End;
-
-Function DtToAmiga(DT: DateTime): LongInt;
-var
-  cd : pClockData;
-  temp : Longint;
-Begin
-  New(cd);
-  cd^.sec   := Dt.sec;
-  cd^.min   := Dt.min;
-  cd^.hour  := Dt.hour;
-  cd^.mday  := Dt.day;
-  cd^.month := Dt.month;
-  cd^.year  := Dt.year;
-  temp := Date2Amiga(cd);
-  Dispose(cd);
-  DtToAmiga := temp;
-end;
-
 function IsLeapYear(Source : Word) : Boolean;
 begin
   if (source Mod 400 = 0) or ((source Mod 4 = 0) and (source Mod 100 <> 0)) then
@@ -324,36 +188,6 @@ begin
 end;
 
 
-{******************************************************************************
-                           --- Dos Interrupt ---
-******************************************************************************}
-
-procedure Intr(intno: byte; var regs: registers);
-begin
-  { Does not apply to MorphOS - not implemented }
-end;
-
-procedure SwapVectors;
-begin
-  { Does not apply to MorphOS - Do Nothing }
-end;
-
-procedure msdos(var regs : registers);
-begin
-  { ! Not implemented in MorphOS ! }
-end;
-
-procedure getintvec(intno : byte;var vector : pointer);
-begin
-  { ! Not implemented in MorphOS ! }
-end;
-
-procedure setintvec(intno : byte;vector : pointer);
-begin
-  { ! Not implemented in MorphOS ! }
-end;
-
-
 {******************************************************************************
                         --- Info / Date / Time ---
 ******************************************************************************}
@@ -588,28 +422,20 @@ Begin
   dispose(cd);
   End;
 
-Procedure unpacktime(p : longint;var t : datetime);
-Begin
-  AmigaToDt(p,t);
-End;
-
 
-Procedure packtime(var t : datetime;var p : longint);
-Begin
-  p := DtToAmiga(t);
+function GetMsCount: int64;
+var
+  TV: TTimeVal;
+begin
+  Get_Sys_Time (@TV);
+  GetMsCount := TV.TV_Secs * 1000 + TV.TV_Micro div 1000;
 end;
 
-
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
 
-Var
-  LastDosExitCode: word;
-  Ver : Boolean;
-
-
 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
   var
    p : string;
@@ -649,12 +475,6 @@ Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
   End;
 
 
-Function DosExitCode: Word;
-  Begin
-    DosExitCode:=LastdosExitCode;
-  End;
-
-
   Procedure GetCBreak(Var BreakValue: Boolean);
   Begin
    breakvalue := system.BreakOn;
@@ -667,17 +487,6 @@ Function DosExitCode: Word;
   End;
 
 
-  Procedure GetVerify(Var Verify: Boolean);
-   Begin
-     verify:=ver;
-   End;
-
-
- Procedure SetVerify(Verify: Boolean);
-  Begin
-    ver:=Verify;
-  End;
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -939,44 +748,6 @@ End;
 {******************************************************************************
                                --- File ---
 ******************************************************************************}
-Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
-var
-  I: Word;
-begin
-  { allow backslash as slash }
-  for i:=1 to length(path) do
-    if path[i]='\' then path[i]:='/';
-
-  I := Length(Path);
-  while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':'))
-     do Dec(I);
-  if Path[I] = '/' then
-     dir := Copy(Path, 0, I)
-  else dir := Copy(Path,0,I);
-
-  if Length(Path) > Length(dir) then
-      name := Copy(Path, I + 1, Length(Path)-I)
-  else
-      name := '';
-  { Remove extension }
-  if pos('.',name) <> 0 then
-   begin
-     ext:=copy(name,pos('.',name),length(name));
-     delete(name,pos('.',name),length(name));
-   end
- else
-   ext := '';
-end;
-
-{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
-{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
-{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
-{$UNDEF FPC_FEXPAND_DRIVESEP_IS_ROOT}
-{$UNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
-
 
 function FSearch(path: PathStr; dirlist: String) : PathStr;
 var
@@ -1242,15 +1013,6 @@ begin
 end;
 
 
-{******************************************************************************
-                             --- Not Supported ---
-******************************************************************************}
-
-Procedure keep(exitcode : word);
-  Begin
-  { ! Not implemented in MorphOS ! }
-  End;
-
 procedure AddDevice(str : String);
 begin
     inc(numberofdevices);
@@ -1304,7 +1066,6 @@ end;
 
 Begin
  DosError:=0;
- ver := TRUE;
  numberofdevices := 0;
  StrOfPaths := '';
  ReadInDevices;
@@ -1312,7 +1073,10 @@ End.
 
 {
   $Log$
-  Revision 1.10  2004-11-23 02:57:58  karoly
+  Revision 1.11  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.10  2004/11/23 02:57:58  karoly
     * Fixed missing $INLINE
 
   Revision 1.9  2004/11/18 22:30:33  karoly

rtl/netware/dos.pp

@@ -17,9 +17,6 @@
 unit dos;
 interface
 
-Const 
-  FileNameLen = 255;
-
 Type
   searchrec = packed record
      DirP  : POINTER;              { used for opendir }
@@ -33,19 +30,24 @@ Type
      name  : string[255]; { NW uses only [12] but more can't hurt }
    end;
 
-  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;
-
 {$i dosh.inc}
 
 implementation
 
 uses
-  strings;
+  strings, nwserv;
+
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_GETCBREAK}
+{$DEFINE HAS_SETSBREAK}
+{$DEFINE HAS_KEEP}
+
+{$define FPC_FEXPAND_DRIVES}
+{$define FPC_FEXPAND_VOLUMES}
+{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
+
+{$I dos.inc}
+
 
 {$ASMMODE ATT}
 {$I nwsys.inc }
@@ -102,37 +104,16 @@ begin
 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;
+function GetMsCount: int64;
+begin
+  GetMsCount := Nwserv.GetCurrentTicks * 55;
+end;
 
 
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  lastdosexitcode : word;
-
 const maxargs=256;
 procedure exec(const path : pathstr;const comline : comstr);
 var c : comstr;
@@ -174,12 +155,6 @@ end;
 
 
 
-function dosexitcode : word;
-begin
-  dosexitcode:=lastdosexitcode;
-end;
-
-
 procedure getcbreak(var breakvalue : boolean);
 begin
   breakvalue := _SetCtrlCharCheckMode (false);  { get current setting }
@@ -194,17 +169,6 @@ begin
 end;
 
 
-procedure getverify(var verify : boolean);
-begin
-  verify := true;
-end;
-
-
-procedure setverify(verify : boolean);
-begin
-end;
-
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -383,90 +347,10 @@ begin
 end;
 
 
-procedure swapvectors;
-begin
-end;
-
-
 {******************************************************************************
                                --- File ---
 ******************************************************************************}
 
-procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
-var
-   dotpos,p1,i : longint;
-begin
-  { allow backslash as slash }
-  for i:=1 to length(path) do
-   if path[i]='\' then path[i]:='/';
-  { get volume name }
-  p1:=pos(':',path);
-  if p1>0 then
-    begin
-       dir:=copy(path,1,p1);
-       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 }
-  //if LFNSupport then
-    begin
-       Ext:='';
-       i:=Length(Path);
-       DotPos:=256;
-       While (i>0) Do
-         Begin
-            If (Path[i]='.') Then
-              begin
-                 DotPos:=i;
-                 break;
-              end;
-            Dec(i);
-         end;
-       Ext:=Copy(Path,DotPos,255);
-       Name:=Copy(Path,1,DotPos - 1);
-    end
-(*  else
-    begin
-       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;*)
-end;
-
-
-function  GetShortName(var p : String) : boolean;
-begin
-  GetShortName := false;
-end;
-
-function  GetLongName(var p : String) : boolean;
-begin
-  GetLongName := false;
-end;
-
-
-{$define FPC_FEXPAND_DRIVES}
-{$define FPC_FEXPAND_VOLUMES}
-{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
-{$i fexpand.inc}
-
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
   i,p1   : longint;
@@ -589,16 +473,26 @@ begin
     GetEnv := '';
     i := 1;
     res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
-    while res = 0 do
-    begin
-      if GetEnv <> '' then GetEnv := GetEnv + ';';
-      GetEnv := GetEnv + envvar0;
-      inc (i);
-      res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
-    end;
-    for i := 1 to length(GetEnv) do
-      if GetEnv[i] = '\' then
-        GetEnv[i] := '/';
+    while res = 0 do
+
+    begin
+
+      if GetEnv <> '' then GetEnv := GetEnv + ';';
+
+      GetEnv := GetEnv + envvar0;
+
+      inc (i);
+
+      res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
+
+    end;
+
+    for i := 1 to length(GetEnv) do
+
+      if GetEnv[i] = '\' then
+
+        GetEnv[i] := '/';
+
   end else
   begin
     strpcopy(envvar0,envvar);
@@ -621,31 +515,14 @@ Begin
  while true do _delay (60000);
 End;
 
-Procedure getintvec(intno : byte;var vector : pointer);
-Begin
- { no netware equivalent }
-End;
-
-Procedure setintvec(intno : byte;vector : pointer);
-Begin
- { no netware equivalent }
-End;
-
-procedure intr(intno : byte;var regs : registers);
-begin
- { no netware equivalent }
-end;
-
-procedure msdos(var regs : registers);
-begin
- { no netware equivalent }
-end;
-
 
 end.
 {
   $Log$
-  Revision 1.11  2004-08-01 20:02:48  armin
+  Revision 1.12  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.11  2004/08/01 20:02:48  armin
   * changed dir separator from \ to /
   * long namespace by default
   * dos.exec implemented

rtl/netwlibc/dos.pp

@@ -19,9 +19,6 @@ interface
 
 uses libc;
 
-Const
-  FileNameLen = 255;
-
 Type
   searchrec = packed record
      DirP  : POINTER;              { used for opendir }
@@ -38,13 +35,6 @@ Type
      _attr : word;
    end;
 
-  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;
-
 {$i dosh.inc}
 {Extra Utils}
 function weekday(y,m,d : longint) : longint;
@@ -55,6 +45,16 @@ implementation
 uses
   strings;
 
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_KEEP}
+
+{$DEFINE FPC_FEXPAND_DRIVES}
+{$DEFINE FPC_FEXPAND_VOLUMES}
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
+
+{$i dos.inc}
+
+
 {$ASMMODE ATT}
 
 {*****************************************************************************
@@ -138,37 +138,20 @@ begin
 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;
+function GetMsCount: int64;
+var
+  tv : TimeVal;
+  tz : TimeZone;
+begin
+  FPGetTimeOfDay (tv, tz);
+  GetMsCount := tv.tv_Sec * 1000 + tv.tv_uSec div 1000;
+end;
 
 
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  lastdosexitcode : word;
-
 const maxargs=256;
 procedure exec(const path : pathstr;const comline : comstr);
 var c : comstr;
@@ -228,33 +211,6 @@ end;
 
 
 
-function dosexitcode : word;
-begin
-  dosexitcode:=lastdosexitcode;
-end;
-
-
-procedure getcbreak(var breakvalue : boolean);
-begin
-end;
-
-
-procedure setcbreak(breakvalue : boolean);
-begin
-end;
-
-
-procedure getverify(var verify : boolean);
-begin
-  verify := true;
-end;
-
-
-procedure setverify(verify : boolean);
-begin
-end;
-
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -493,78 +449,10 @@ begin
 end;
 
 
-procedure swapvectors;
-begin
-end;
-
-
 {******************************************************************************
                                --- File ---
 ******************************************************************************}
 
-procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
-var
-   dotpos,p1,i : longint;
-begin
-  { allow backslash as slash }
-  for i:=1 to length(path) do
-   if path[i]='\' then path[i]:='/';
-  { get volume name }
-  p1:=pos(':',path);
-  if p1>0 then
-    begin
-       dir:=copy(path,1,p1);
-       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 }
-  //if LFNSupport then
-    begin
-       Ext:='';
-       i:=Length(Path);
-       DotPos:=256;
-       While (i>0) Do
-         Begin
-            If (Path[i]='.') Then
-              begin
-                 DotPos:=i;
-                 break;
-              end;
-            Dec(i);
-         end;
-       Ext:=Copy(Path,DotPos,255);
-       Name:=Copy(Path,1,DotPos - 1);
-    end
-end;
-
-
-function  GetShortName(var p : String) : boolean;
-begin
-  GetShortName := false;
-end;
-
-function  GetLongName(var p : String) : boolean;
-begin
-  GetLongName := false;
-end;
-
-
-{$define FPC_FEXPAND_DRIVES}
-{$define FPC_FEXPAND_VOLUMES}
-{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
-{$i fexpand.inc}
-
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
   i,p1   : longint;
@@ -798,31 +686,14 @@ Begin
  while true do delay (60000);
 End;
 
-Procedure getintvec(intno : byte;var vector : pointer);
-Begin
- { no netware equivalent }
-End;
-
-Procedure setintvec(intno : byte;vector : pointer);
-Begin
- { no netware equivalent }
-End;
-
-procedure intr(intno : byte;var regs : registers);
-begin
- { no netware equivalent }
-end;
-
-procedure msdos(var regs : registers);
-begin
- { no netware equivalent }
-end;
-
 
 end.
 {
   $Log$
-  Revision 1.4  2004-09-26 19:23:34  armin
+  Revision 1.5  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.4  2004/09/26 19:23:34  armin
   * exiting threads at nlm unload
   * renamed some libc functions
 

rtl/unix/dos.pp

@@ -15,10 +15,6 @@
 Unit Dos;
 Interface
 
-Const
-  {Max FileName Length for files}
-  FileNameLen=255;
-
 Type
 
   SearchRec =
@@ -43,16 +39,6 @@ Type
     NamePos    : Word;        {end of path, start of name position}
   End;
 
-
-{$ifdef cpui386}
-  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;
-{$endif cpui386}
-
 {$i dosh.inc}
 
 {Extra Utils}
@@ -68,6 +54,14 @@ Implementation
 Uses
   Strings,Unix,BaseUnix,{$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF};
 
+{$DEFINE HAS_GETMSCOUNT}
+
+{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
+{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
+
+{$I dos.inc}
+
+
 {$ifndef FPC_USE_LIBC}
 {$i sysnr.inc}
 {$endif}
@@ -261,6 +255,7 @@ begin
   fpSettimeofday(@tv,nil);
 end;
 
+
 Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
 var
   tv : timeval;
@@ -269,6 +264,7 @@ begin
   SetDatetime:=fpSettimeofday(@tv,nil)=0;
 end;
 
+
 Procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
 var
   tz:timeval;
@@ -279,23 +275,6 @@ begin
   sec100:=tz.tv_usec div 10000;
 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
-  t.sec:=(p and 31) shl 1;
-  t.min:=(p shr 5) and 63;
-  t.hour:=(p shr 11) and 31;
-  t.day:=(p shr 16) and 31;
-  t.month:=(p shr 21) and 15;
-  t.year:=(p shr 25)+1980;
-End;
-
 
 Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
 Begin
@@ -303,52 +282,26 @@ Begin
 End;
 
 
-
 Function DTToUnixDate(DT: DateTime): LongInt;
 Begin
   DTToUnixDate:=LocalToEpoch(dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
 End;
 
 
+function GetMsCount: int64;
+var
+   tv : TimeVal;
+{  tz : TimeZone;}
+begin
+  FPGetTimeOfDay (@tv, nil {,tz});
+  GetMsCount := tv.tv_Sec * 1000 + tv.tv_uSec div 1000;
+end;
+
 
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
-Procedure FSplit( Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
-Var
-  DotPos,SlashPos,i : longint;
-Begin
-  SlashPos:=0;
-  DotPos:=256;
-  i:=Length(Path);
-  While (i>0) and (SlashPos=0) Do
-   Begin
-     If (DotPos=256) and (Path[i]='.') Then
-      begin
-        DotPos:=i;
-      end;
-     If (Path[i]='/') Then
-      SlashPos:=i;
-     Dec(i);
-   End;
-  Ext:=Copy(Path,DotPos,255);
-  Dir:=Copy(Path,1,SlashPos);
-  Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
-End;
-
-
-{$ifdef HASTHREADVAR}
-{$ifdef VER1_9_2}
-var
-{$else VER1_9_2}
-threadvar
-{$endif VER1_9_2}
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  LastDosExitCode: word;
-
 Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
 var
   pid      : longint; // pid_t?
@@ -396,13 +349,6 @@ Begin
 End;
 
 
-
-Function DosExitCode: Word;
-Begin
-  DosExitCode:=LastDosExitCode;
-End;
-
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -797,17 +743,6 @@ End;
                                --- File ---
 ******************************************************************************}
 
-
-{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
-{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_GETENVPCHAR}
-{$UNDEF FPC_FEXPAND_TILDE}
-
-
-
 Function FSearch(path : pathstr;dirlist : string) : pathstr;
 Var
   info : BaseUnix.stat;
@@ -936,54 +871,6 @@ Begin
 End;
 
 
-{******************************************************************************
-                      --- Do Nothing Procedures/Functions ---
-******************************************************************************}
-
-{$ifdef cpui386}
-Procedure Intr (intno: byte; var regs: registers);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
-Procedure msdos(var regs : registers);
-Begin
-  {! No Unix equivalent !}
-End;
-{$endif cpui386}
-
-
-
-Procedure getintvec(intno : byte;var vector : pointer);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
-Procedure setintvec(intno : byte;vector : pointer);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
-Procedure SwapVectors;
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
-Procedure keep(exitcode : word);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
 Procedure setfattr (var f;attr : word);
 Begin
   {! No Unix equivalent !}
@@ -994,49 +881,6 @@ End;
 
 
 
-Procedure GetCBreak(Var BreakValue: Boolean);
-Begin
-{! No Unix equivalent !}
-  breakvalue:=true
-End;
-
-
-
-Procedure SetCBreak(BreakValue: Boolean);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-
-Procedure GetVerify(Var Verify: Boolean);
-Begin
-  {! No Unix equivalent !}
-  Verify:=true;
-End;
-
-
-
-Procedure SetVerify(Verify: Boolean);
-Begin
-  {! No Unix equivalent !}
-End;
-
-
-function  GetShortName(var p : String) : boolean;
-
-begin
- { short=long under *nix}
- GetShortName:=True;
-end;
-
-function  GetLongName(var p : String) : boolean;
-begin
-  { short=long under *nix}
- GetLongName:=True;
-end;
-
-
 {******************************************************************************
                             --- Initialization ---
 ******************************************************************************}
@@ -1045,7 +889,10 @@ End.
 
 {
   $Log$
-  Revision 1.39  2004-12-02 18:24:35  marco
+  Revision 1.40  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.39  2004/12/02 18:24:35  marco
    * fpsettimeofday.
 
   Revision 1.38  2004/10/31 17:11:52  marco

rtl/watcom/dos.pp

@@ -20,9 +20,6 @@ Uses
   Watcom;
 
 
-Const
-  FileNameLen = 255;
-  
 Type
   searchrec = packed record
      fill : array[1..21] of byte;
@@ -33,6 +30,7 @@ Type
      name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
   end;
 
+{$DEFINE HAS_REGISTERS}
   Registers = Watcom.Registers;
 
 {$i dosh.inc}
@@ -42,6 +40,22 @@ implementation
 uses
   strings;
 
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_INTR}
+{$DEFINE HAS_GETCBREAK}
+{$DEFINE HAS_SETCBREAK}
+{$DEFINE HAS_GETVERIFY}
+{$DEFINE HAS_SETVERIFY}
+{$DEFINE HAS_GETSHORTNAME}
+{$DEFINE HAS_GETLONGNAME}
+{$DEFINE HAS_GETMSCOUNT}
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+{$I dos.inc}
+
+
 {******************************************************************************
                            --- Dos Interrupt ---
 ******************************************************************************}
@@ -82,12 +96,6 @@ begin
 end;
 
 
-procedure msdos(var regs : registers);
-begin
-  intr($21,regs);
-end;
-
-
 {******************************************************************************
                         --- Info / Date / Time ---
 ******************************************************************************}
@@ -142,38 +150,15 @@ begin
   msdos(dosregs);
 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;
-
+function GetMsCount: int64;
+begin
+  GetMsCount := MemL [$40:$6c] * 55;
+end;
 
 {******************************************************************************
                                --- Exec ---
 ******************************************************************************}
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  lastdosexitcode : word;
-
 procedure exec(const path : pathstr;const comline : comstr);
 type
   realptr = packed record
@@ -296,12 +281,6 @@ begin
 end;
 
 
-function dosexitcode : word;
-begin
-  dosexitcode:=lastdosexitcode;
-end;
-
-
 procedure getcbreak(var breakvalue : boolean);
 begin
   dosregs.ax:=$3300;
@@ -618,7 +597,7 @@ begin
 end;
 
 
-type swap_proc = procedure;
+//type swap_proc = procedure;
 
 //var
 //  _swap_in  : swap_proc;external name '_swap_in';
@@ -626,93 +605,22 @@ type swap_proc = procedure;
 //  _exception_exit : pointer;external name '_exception_exit';
 //  _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';
 
+(*
 procedure swapvectors;
 begin
-(*  if _exception_exit<>nil then
+  if _exception_exit<>nil then
     if _v2prt0_exceptions_on then
       _swap_out()
     else
-      _swap_in();*)
+      _swap_in();
 end;
+*)
 
 
 {******************************************************************************
                                --- File ---
 ******************************************************************************}
 
-procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
-var
-   dotpos,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 }
-  if LFNSupport then
-    begin
-       Ext:='';
-       i:=Length(Path);
-       DotPos:=256;
-       While (i>0) Do
-         Begin
-            If (Path[i]='.') Then
-              begin
-                 DotPos:=i;
-                 break;
-              end;
-            Dec(i);
-         end;
-       Ext:=Copy(Path,DotPos,255);
-       Name:=Copy(Path,1,DotPos - 1);
-    end
-  else
-    begin
-       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;
-end;
-
-
-(*
-function FExpand (const Path: PathStr): PathStr;
-- declared in fexpand.inc
-*)
-
-{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
-{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_DRIVES}
-{$UNDEF FPC_FEXPAND_UNC}
-
-
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
   i,p1   : longint;
@@ -930,28 +838,14 @@ begin
 end;
 
 
-{******************************************************************************
-                             --- 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.8  2004-02-17 17:37:26  daniel
+  Revision 1.9  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.8  2004/02/17 17:37:26  daniel
     * Enable threadvars again
 
   Revision 1.7  2004/02/16 22:18:44  hajny

rtl/win32/dos.pp

@@ -1,7 +1,7 @@
 {
     $Id$
     This file is part of the Free Pascal run time library.
-    Copyright (c) 1999-2000 by the Free Pascal development team.
+    Copyright (c) 1999-2004 by the Free Pascal development team.
 
     Dos unit for BP7 compatible RTL
 
@@ -18,7 +18,6 @@ interface
 
 Const
   Max_Path    = 260;
-  FileNameLen = 255;
 
 Type
   TWin32Handle = longint;
@@ -55,18 +54,8 @@ Type
     name : string;
   end;
 
-
-  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;
-
 {$i dosh.inc}
 
-
-
 Const
   { allow EXEC to inherited handles from calling process,
     needed for FPREDIR in ide/text
@@ -81,6 +70,15 @@ implementation
 uses
    strings;
 
+{$DEFINE HAS_GETMSCOUNT}
+{$DEFINE HAS_GETSHORTNAME}
+{$DEFINE HAS_GETLONGNAME}
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+{$I dos.inc}
+
 const
    INVALID_HANDLE_VALUE = longint($ffffffff);
 
@@ -116,6 +114,13 @@ var
      stdcall; external 'kernel32' name 'FileTimeToLocalFileTime';
    function LocalFileTimeToFileTime(const lft : TWin32FileTime;var ft : TWin32FileTime) : longbool;
      stdcall; external 'kernel32' name 'LocalFileTimeToFileTime';
+   function GetTickCount : longint;
+     stdcall;external 'kernel32' name 'GetTickCount';
+
+function GetMsCount: int64;
+begin
+  GetMsCount := cardinal (GetTickCount);
+end;
 
 type
   Longrec=packed record
@@ -163,21 +168,6 @@ begin
 end;
 
 
-{******************************************************************************
-                           --- Dos Interrupt ---
-******************************************************************************}
-
-procedure intr(intno : byte;var regs : registers);
-begin
-  { !!!!!!!! }
-end;
-
-procedure msdos(var regs : registers);
-begin
-  { !!!!!!!! }
-end;
-
-
 {******************************************************************************
                         --- Info / Date / Time ---
 ******************************************************************************}
@@ -263,26 +253,6 @@ begin
 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 ---
 ******************************************************************************}
@@ -309,13 +279,6 @@ type
    function CloseHandle(h : TWin32Handle) : longint;
      stdcall; external 'kernel32' name 'CloseHandle';
 
-{$ifdef HASTHREADVAR}
-threadvar
-{$else HASTHREADVAR}
-var
-{$endif HASTHREADVAR}
-  lastdosexitcode : longint;
-
 procedure exec(const path : pathstr;const comline : comstr);
 var
   SI: TStartupInfo;
@@ -364,38 +327,6 @@ begin
 end;
 
 
-function dosexitcode : word;
-begin
-  dosexitcode:=lastdosexitcode and $ffff;
-end;
-
-
-procedure getcbreak(var breakvalue : boolean);
-begin
-{ !! No Win32 Function !! }
-  breakvalue := true;
-end;
-
-
-procedure setcbreak(breakvalue : boolean);
-begin
-{ !! No Win32 Function !! }
-end;
-
-
-procedure getverify(var verify : boolean);
-begin
-{ !! No Win32 Function !! }
- verify := true;
-end;
-
-
-procedure setverify(verify : boolean);
-begin
-{ !! No Win32 Function !! }
-end;
-
-
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
@@ -579,11 +510,6 @@ begin
 end;
 
 
-procedure swapvectors;
-begin
-end;
-
-
 Procedure FindClose(Var f: SearchRec);
 begin
   If longint(F.FindHandle)<>Invalid_Handle_value then
@@ -604,48 +530,6 @@ end;
    function GetFileAttributes(lpFileName : pchar) : longint;
      stdcall; external 'kernel32' name 'GetFileAttributesA';
 
-procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
-var
-   dotpos,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 }
-   Ext:='';
-   i:=Length(Path);
-   DotPos:=256;
-   While (i>0) Do
-     Begin
-        If (Path[i]='.') Then
-          begin
-             DotPos:=i;
-             break;
-          end;
-        Dec(i);
-     end;
-   Ext:=Copy(Path,DotPos,255);
-   Name:=Copy(Path,1,DotPos - 1);
-end;
 
 { <immobilizer> }
 
@@ -656,19 +540,6 @@ function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWO
     stdcall; external 'kernel32' name 'GetShortPathNameA';
 
 
-(*
-function FExpand (const Path: PathStr): PathStr;
-- declared in fexpand.inc
-*)
-
-{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
-{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
-
-{$I fexpand.inc}
-
-{$UNDEF FPC_FEXPAND_DRIVES}
-{$UNDEF FPC_FEXPAND_UNC}
-
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
   i,p1   : longint;
@@ -905,22 +776,6 @@ begin
 end;
 
 
-{******************************************************************************
-                             --- 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;
-
 function FreeLibrary(hLibModule : TWin32Handle) : longbool;
   stdcall; external 'kernel32' name 'FreeLibrary';
 function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
@@ -959,7 +814,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.28  2004-04-07 09:26:23  michael
+  Revision 1.29  2004-12-05 16:44:43  hajny
+    * GetMsCount added, platform independent routines moved to single include file
+
+  Revision 1.28  2004/04/07 09:26:23  michael
   + Patch for findfirst (bug 3042) from Peter Vreman
 
   Revision 1.27  2004/03/14 18:43:21  peter