* common implementation of platform independent functions for unit Dos

rtl/inc/dos.inc

@@ -0,0 +1,297 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2004 by Tomas Hajny,
+    member of the Free Pascal development team.
+
+    Common implementations of functions for unit Dos
+    (including dummy implementation of some functions for platforms
+    missing real implementation).
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+(* Everywhere the same now, but prepared for potential difference. *)
+const
+ ExtensionSeparator = '.';
+
+{$IFNDEF HAS_DOSEXITCODE}
+ {$IFDEF HASTHREADVAR}
+threadvar
+ {$ELSE HASTHREADVAR}
+var
+ {$ENDIF HASTHREADVAR}
+  LastDosExitCode: longint;
+
+
+function DosExitCode: word;
+begin
+  if LastDosExitCode > high (word) then
+    DosExitCode := high (word)
+  else
+    DosExitCode := LastDosExitCode and $FFFF;
+end;
+{$ENDIF HAS_DOSEXITCODE}
+
+
+{$IFNDEF HAS_GETMSCOUNT}
+ {$WARNING Real GetMsCount implementation missing, dummy version used}
+{Dummy implementation of GetMsCount for platforms missing anything better.}
+function GetMsCount: int64;
+var
+  Y, Mo, D, WD, H, Mi, S, S100: word;
+const
+  DayTable: array[Boolean, 1..12] of longint =
+      ((0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334),
+       (0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335));
+
+ function Leap: boolean;
+ begin
+  if (Y mod 400) = 0 then
+   Leap := true
+  else
+   if ((Y mod 100) = 0) or ((Y mod 4) <> 0) then
+    Leap := false
+   else
+    Leap := true;
+ end;
+
+ {$IFDEF VER1_0}
+{ Necessary to avoid internal error 10... :-( }
+var
+ DC: cardinal;
+ I64: int64;
+ {$ENDIF VER1_0}
+begin
+  GetDate (Y, Mo, D, WD);
+  GetTime (H, Mi, S, S100);
+ {$IFDEF VER1_0}
+  DC := D + DayTable [Leap, Mo] + (Y div 400) * 97;
+  DC := DC + ((Y mod 400) div 100) * 24 + (Y mod 100) div 4;
+  I64 := S100 * 10 + S * 1000;
+  I64 := I64 + cardinal (Mi) * 60*1000;
+  I64 := I64 + int64 (H) * 60*60*1000;
+  I64 := I64 + int64 (DC) * 24*60*60*1000;
+  I64 := I64 + int64 (Y) * 365*24*60*60*1000;
+  GetMsCount := I64;
+ {$ELSE VER1_0}
+  GetMsCount := S100 * 10 + S * 1000 + cardinal (Mi) * 60*1000
+       + int64 (H) * 60*60*1000
+        + int64 (D + DayTable [Leap, Mo]
+          + (Y div 400) * 97 + ((Y mod 400) div 100) * 24 + (Y mod 100) div 4)
+                                                                * 24*60*60*1000
+         + int64 (Y) * 365*24*60*60*1000;
+ {$ENDIF VER1_0}
+end;
+{$ENDIF HAS_GETMSCOUNT}
+
+
+{$IFNDEF HAS_GETCBREAK}
+procedure GetCBreak (var BreakValue: boolean);
+begin
+  BreakValue := true;
+end;
+{$ENDIF HAS_GETCBREAK}
+
+
+{$IFNDEF HAS_SETCBREAK}
+procedure SetCBreak (BreakValue: boolean);
+begin
+end;
+{$ENDIF HAS_SETCBREAK}
+
+
+{$IFNDEF HAS_GETVERIFY}
+procedure GetVerify (var Verify: boolean);
+begin
+  Verify := true;
+end;
+{$ENDIF HAS_GETVERIFY}
+
+
+{$IFNDEF HAS_SETVERIFY}
+procedure SetVerify (Verify: boolean);
+begin
+end;
+{$ENDIF HAS_SETVERIFY}
+
+
+{$IFDEF CPUI386}
+ {$IFNDEF HAS_INTR}
+procedure Intr (IntNo: byte; var Regs: Registers);
+begin
+end;
+ {$ENDIF HAS_INTR}
+
+
+ {$IFNDEF HAS_MSDOS}
+procedure MSDos (var Regs: Registers);
+begin
+  Intr ($21, Regs);
+end;
+ {$ENDIF HAS_MSDOS}
+{$ENDIF CPUI386}
+
+
+{$IFNDEF HAS_SWAPVECTORS}
+procedure SwapVectors;
+begin
+end;
+{$ENDIF HAS_SWAPVECTORS}
+
+
+{$IFNDEF HAS_GETINTVEC}
+procedure GetIntVec (IntNo: byte; var Vector: pointer);
+begin
+  Vector := nil;
+end;
+{$ENDIF HAS_GETINTVEC}
+
+
+{$IFNDEF HAS_SETINTVEC}
+procedure SetIntVec (IntNo: byte; Vector: pointer);
+begin
+end;
+{$ENDIF HAS_SETINTVEC}
+
+
+{$IFNDEF HAS_KEEP}
+procedure Keep (ExitCode: word);
+begin
+end;
+{$ENDIF HAS_KEEP}
+
+
+{$IFNDEF HAS_GETSHORTNAME}
+function GetShortName (var P: String): boolean;
+begin
+  GetShortName := true;
+end;
+{$ENDIF HAS_GETSHORTNAME}
+
+
+{$IFNDEF HAS_GETLONGNAME}
+function GetLongName (var P: String): boolean;
+begin
+  GetLongName := true;
+end;
+{$ENDIF HAS_GETLONGNAME}
+
+
+{PackTime is platform independent}
+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;
+
+{UnpackTime is platform-independent}
+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;
+
+
+{****************************************************************************
+               A platform independent implementation of FSplit
+****************************************************************************}
+
+{$IFNDEF HAS_FSPLIT}
+Procedure FSplit (Path: PathStr; var Dir: DirStr; var Name: NameStr; var Ext: ExtStr);
+var
+  DirEnd, ExtStart: cardinal;
+begin
+  if DirectorySeparator = '/' then
+  { allow backslash as slash }
+    for DirEnd := 1 to Length (Path) do
+      begin
+        if Path [DirEnd] = '\' then Path [DirEnd] := DirectorySeparator
+      end
+  else
+    if DirectorySeparator = '\' then
+    { allow slash as backslash }
+      for DirEnd := 1 to Length (Path) do
+        if Path [DirEnd] = '/' then Path [DirEnd] := DirectorySeparator;
+
+{ Find the first DirectorySeparator or DriveSeparator from the end. }
+  DirEnd := Length (Path);
+  while (DirEnd > 0) and not (Path [DirEnd] in
+                                       [DirectorySeparator, DriveSeparator]) do
+    Dec (DirEnd);
+
+{ The first "extension" should be returned if LFN }
+{ support not available, the last one otherwise.  }
+  if LFNSupport then
+    begin
+      ExtStart := Length (Path);
+      while (ExtStart > DirEnd) and (Path [ExtStart] <> ExtensionSeparator) do
+        Dec (ExtStart);
+      if ExtStart = 0 then
+        ExtStart := Length (Path) + 1
+      else
+        if Path [ExtStart] <> ExtensionSeparator then
+          ExtStart := Length (Path) + 1;
+    end
+  else
+    begin
+      ExtStart := DirEnd + 1;
+      while (ExtStart <= Length (Path)) and (Path [ExtStart] <> ExtensionSeparator) do
+        Inc (ExtStart);
+    end;
+
+  Dir := Copy (Path, 1, DirEnd);
+  Name := Copy (Path, DirEnd + 1, ExtStart - DirEnd - 1);
+  Ext := Copy (Path, ExtStart, Length (Path) - ExtStart + 1);
+end;
+{$ENDIF HAS_FSPLIT}
+
+
+{****************************************************************************
+               A platform independent implementation of FExpand
+****************************************************************************}
+
+{$IFNDEF HAS_FEXPAND}
+
+(* FExpand maintained in standalone include file for easier maintenance. *)
+{$I fexpand.inc}
+
+{$ENDIF HAS_FEXPAND}
+
+{
+  $Log$
+  Revision 1.1  2004-11-28 12:33:35  hajny
+    * common implementation of platform independent functions for unit Dos
+
+
+}