paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 18:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* added (limited) GetLastOSError by emulation of Win32 and *nix behaviour in the RTL

Browse Source 
git-svn-id: trunk@28947 -
This commit is contained in:
Tomas Hajny 2014-10-30 14:44:03 +00:00
parent 3296c3d381
commit 8cd2b615ce
10 changed files with 836 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
rtl/os2/dos.pas
View File

@ -113,6 +113,8 @@ begin
P:=Path;
D:=DirList;
DosError := DosSearchPath (dsIgnoreNetErrs, PChar(D), PChar(P), @A, 255);
if DosError <> 0 then
OSErrorWatch (DosError);
fsearch := StrPas (@A);
end;
@ -124,12 +126,16 @@ begin
DosError := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat));
if DosError=0 then
begin
begin
Time := FStat.TimeLastWrite + longint (FStat.DateLastWrite) shl 16;
if Time = 0 then
Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16;
end else
end
else
begin
Time:=0;
OSErrorWatch (DosError);
end;
end;
@ -140,14 +146,18 @@ begin
RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat));
if RC = 0 then
begin
begin
FStat.DateLastAccess := Hi (Time);
FStat.DateLastWrite := Hi (Time);
FStat.TimeLastAccess := Lo (Time);
FStat.TimeLastWrite := Lo (Time);
RC := DosSetFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat));
end;
if RC <> 0 then
OSErrorWatch (RC);
end
else
OSErrorWatch (RC);
DosError := integer (RC);
end;
@ -170,7 +180,10 @@ begin
LastExecRes := Res;
end
else
LastExecRes.ExitCode := RC shl 16;
begin
LastExecRes.ExitCode := RC shl 16;
OSErrorWatch (RC);
end;
end;
if LastExecRes.ExitCode > high (word) then
DosExitCode := high (word)
@ -186,7 +199,7 @@ var
ArgSize: word;
ObjName: string;
Res: TResultCodes;
RC: cardinal;
RC, RC2: cardinal;
ExecAppType: cardinal;
HQ: THandle;
SPID, STID, SCtr, QName: string;
@ -239,22 +252,28 @@ begin
Args^ [ArgSize] := 0;
end;
if (DosQueryAppType (PChar (Args), ExecAppType) = 0) and
(ApplicationType and 3 = ExecAppType and 3) then
RC := DosQueryAppType (PChar (Args), ExecAppType);
if RC <> 0 then
OSErrorWatch (RC)
else
if (ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *)
begin
DSS := false;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
if RC = 0 then
begin
LastExecFlags := ExecFlags;
LastExecRes := Res;
LastDosErrorModuleName := '';
end
else
if (RC = 190) or (RC = 191) then
DSS := true;
begin
DSS := false;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
if RC = 0 then
begin
LastExecFlags := ExecFlags;
LastExecRes := Res;
LastDosErrorModuleName := '';
end
else
begin
if (RC = 190) or (RC = 191) then
DSS := true;
OSErrorWatch (RC);
end;
end
else
DSS := true;
@ -273,6 +292,8 @@ begin
LastExecFlags := ExecFlags;
SD.TermQ := @QName [1];
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
if RC <> 0 then
OSErrorWatch (RC);
end;
deAsync,
deAsyncResult:
@ -318,24 +339,40 @@ begin
SD.ObjectBuffer := @ObjName [1];
SD.ObjectBuffLen := SizeOf (ObjName) - 1;
RC := DosStartSession (SD, SID, PID);
if RC <> 0 then
OSErrorWatch (RC);
if (RC = 0) or (RC = 457) then
begin
LastExecRes.PID := PID;
if ExecFlags = deSync then
begin
RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
if RC <> 0 then
OSErrorWatch (RC);
if (RC = 0) and (PCI^.SessionID = SID) then
begin
LastExecRes.ExitCode := PCI^.Return;
DosCloseQueue (HQ);
DosFreeMem (PCI);
RC2 := DosCloseQueue (HQ);
if RC2 <> 0 then
OSErrorWatch (RC2);
RC2 := DosFreeMem (PCI);
if RC2 <> 0 then
OSErrorWatch (RC2);
end
else
DosCloseQueue (HQ);
begin
RC2 := DosCloseQueue (HQ);
if RC2 <> 0 then
OSErrorWatch (RC2);
end;
end;
end
else if ExecFlags = deSync then
DosCloseQueue (HQ);
begin
RC2 := DosCloseQueue (HQ);
if RC2 <> 0 then
OSErrorWatch (RC2);
end;
end;
end;
if RC <> 0 then
@ -383,12 +420,15 @@ end;
procedure SetDate (Year, Month, Day: word);
var
DT: TDateTime;
RC: cardinal;
begin
DosGetDateTime (DT);
DT.Year := Year;
DT.Month := byte (Month);
DT.Day := byte (Day);
DosSetDateTime (DT);
RC := DosSetDateTime (DT);
if RC <> 0 then
OSErrorWatch (RC);
end;
@ -407,6 +447,7 @@ end;
procedure SetTime (Hour, Minute, Second, Sec100: word);
var
DT: TDateTime;
RC: cardinal;
begin
DosGetDateTime (DT);
DT.Hour := byte (Hour);
@ -414,6 +455,8 @@ begin
DT.Second := byte (Second);
DT.Sec100 := byte (Sec100);
DosSetDateTime (DT);
if RC <> 0 then
OSErrorWatch (RC);
end;
function DiskFree (Drive: byte): int64;
@ -426,7 +469,10 @@ begin
DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskFree := -1;
begin
DiskFree := -1;
OSErrorWatch (RC);
end;
end;
@ -439,7 +485,10 @@ begin
DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskSize := -1;
begin
DiskSize := -1;
OSErrorWatch (RC);
end;
end;
@ -474,7 +523,10 @@ begin
DosError := integer (DosFindFirst (Path, F.Handle,
Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
Count, ilStandard));
if (DosError = 0) and (Count = 0) then DosError := 18;
if DosError <> 0 then
OSErrorWatch (DosError)
else if Count = 0 then
DosError := 18;
DosSearchRec2SearchRec (F);
end;
@ -488,14 +540,22 @@ begin
Count := 1;
DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^),
Count));
if (DosError = 0) and (Count = 0) then DosError := 18;
if DosError <> 0 then
OSErrorWatch (DosError)
else if Count = 0 then
DosError := 18;
DosSearchRec2SearchRec (F);
end;
procedure FindClose (var F: SearchRec);
begin
if F.Handle <> THandle ($FFFFFFFF) then DosError := DosFindClose (F.Handle);
if F.Handle <> THandle ($FFFFFFFF) then
begin
DosError := integer (DosFindClose (F.Handle));
if DosError <> 0 then
OSErrorWatch (DosError);
end;
Dispose (F.FStat);
end;
@ -607,7 +667,9 @@ begin
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
DosError := integer (RC);
if RC = 0 then
Attr := PathInfo.AttrFile;
Attr := PathInfo.AttrFile
else
OSErrorWatch (RC);
end;
@ -628,11 +690,15 @@ begin
{$endif FPC_ANSI_TEXTFILEREC}
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
if RC = 0 then
begin
begin
PathInfo.AttrFile := Attr;
RC := DosSetPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo),
doWriteThru);
end;
if RC <> 0 then
OSErrorWatch (RC);
end
else
OSErrorWatch (RC);
DosError := integer (RC);
end;

33
rtl/os2/dynlibs.inc
View File

@ -54,7 +54,10 @@ begin
if DynLibErrNo = 0 then
Result := Handle
else
Result := NilHandle;
begin
Result := NilHandle;
OSErrorWatch (DynLibErrNo);
end;
end;
function GetProcedureAddress (Lib: TLibHandle; const ProcName: AnsiString): pointer;
@ -66,7 +69,10 @@ begin
if DynLibErrNo = 0 then
Result := P
else
Result := nil;
begin
Result := nil;
OSErrorWatch (DynLibErrNo);
end;
end;
function GetProcedureAddress (Lib: TLibHandle; Ordinal: TOrdinalEntry): pointer;
@ -78,7 +84,10 @@ begin
if DynLibErrNo = 0 then
Result := P
else
Result := nil;
begin
Result := nil;
OSErrorWatch (DynLibErrNo);
end;
end;
function UnloadLibrary (Lib: TLibHandle): boolean;
@ -86,6 +95,8 @@ begin
DynLibErrPath [0] := #0;
DynLibErrNo := DosFreeModule (Lib);
Result := DynLibErrNo = 0;
if DynLibErrNo <> 0 then
OSErrorWatch (DynLibErrNo);
end;
function GetDynLibsError: longint;
@ -102,22 +113,26 @@ var
RetMsgSize: cardinal;
RC: cardinal;
begin
if DynLibErrNo = 0 then
GetDynLibsErrorStr := ''
else
GetDynLibsErrorStr := '';
if DynLibErrNo <> 0 then
begin
Result := '';
VarArr [1] := @DynLibErrPath [0];
RC := DosGetMessage (@VarArr, 1, @OutBuf [0], SizeOf (OutBuf),
DynLibErrNo, @SysMsgFile [0], RetMsgSize);
if RC = 0 then
Result := StrPas (@OutBuf [0])
begin
SetLength (Result, RetMsgSize);
Move (OutBuf [0], Result [1], RetMsgSize);
end
else
begin
Str (DynLibErrNo, Result);
Result := 'Error ' + Result;
if DynLibErrPath [0] <> #0 then
Result := StrPas (@DynLibErrPath [0]) + ' - ' + Result;
OSErrorWatch (RC);
end;
if DynLibErrPath [0] <> #0 then
Result := StrPas (@DynLibErrPath [0]) + ' - ' + Result;
end;
end;

18
rtl/os2/sysdir.inc
View File

@ -29,6 +29,7 @@ begin
begin
InOutRes := Rc;
Errno2Inoutres;
OSErrorWatch (RC);
end;
end;
@ -47,6 +48,7 @@ begin
begin
InOutRes := Rc;
Errno2Inoutres;
OSErrorWatch (RC);
end;
end;
@ -63,7 +65,10 @@ begin
begin
RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40);
if RC <> 0 then
InOutRes := RC
begin
InOutRes := RC;
OSErrorWatch (RC);
end
else
if Len > 2 then
begin
@ -75,6 +80,7 @@ begin
begin
InOutRes := RC;
Errno2InOutRes;
OSErrorWatch (RC);
end;
end;
end else begin
@ -86,6 +92,7 @@ begin
begin
InOutRes:= RC;
Errno2InOutRes;
OSErrorWatch (RC);
end;
end;
end;
@ -97,6 +104,7 @@ procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var sof: Pchar;
i:byte;
l,l2:cardinal;
RC: cardinal;
begin
setlength(Dir,255);
Dir [4] := #0;
@ -109,7 +117,13 @@ begin
{ TODO: if max path length is > 255, increase the setlength parameter above and
the 255 below }
l:=255-3;
InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l));
RC := DosQueryCurrentDir(DriveNr, sof^, l);
if RC <> 0 then
begin
InOutRes := longint (RC);
Errno2Inoutres;
OSErrorWatch (RC);
end;
{$WARNING Result code should be translated in some cases!}
{ Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] }

146
rtl/os2/sysfile.inc
View File

@ -2,7 +2,7 @@
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
Low leve file functions
Low level file functions
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -20,12 +20,19 @@
****************************************************************************}
procedure do_close(h:thandle);
var
RC: cardinal;
begin
{ Only three standard handles under real OS/2 }
if h>2 then
begin
InOutRes:=DosClose(h);
end;
begin
RC := DosClose (H);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
end;
{$ifdef IODEBUG}
writeln('do_close: handle=', H, ', InOutRes=', InOutRes);
{$endif}
@ -34,10 +41,16 @@ end;
procedure do_erase(p:Pchar; pchangeable: boolean);
var
oldp: pchar;
RC: cardinal;
begin
oldp:=p;
DoDirSeparators(p,pchangeable);
inoutres:=DosDelete(p);
RC := DosDelete (P);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
if p<>oldp then
freemem(p);
end;
@ -45,12 +58,18 @@ end;
procedure do_rename(p1,p2:Pchar; p1changeable, p2changeable: boolean);
var
oldp1, oldp2 : pchar;
RC: cardinal;
begin
oldp1:=p1;
oldp2:=p2;
DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable);
inoutres:=DosMove(p1, p2);
RC := DosMove (p1, p2);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
if p1<>oldp1 then
freemem(p1);
if p2<>oldp2 then
@ -60,11 +79,17 @@ end;
function do_read(h:thandle;addr:pointer;len:longint):longint;
Var
T: cardinal;
RC: cardinal;
begin
{$ifdef IODEBUG}
write('do_read: handle=', h, ', addr=', ptrint(addr), ', length=', len);
{$endif}
InOutRes:=DosRead(H, Addr, Len, T);
RC := DosRead(H, Addr, Len, T);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
do_read:= longint (T);
{$ifdef IODEBUG}
writeln(', actual_len=', t, ', InOutRes=', InOutRes);
@ -74,11 +99,17 @@ end;
function do_write(h:thandle;addr:pointer;len:longint) : longint;
Var
T: cardinal;
RC: cardinal;
begin
{$ifdef IODEBUG}
write('do_write: handle=', h, ', addr=', ptrint(addr), ', length=', len);
{$endif}
InOutRes:=DosWrite(H, Addr, Len, T);
RC := DosWrite(H, Addr, Len, T);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
do_write:= longint (T);
{$ifdef IODEBUG}
writeln(', actual_len=', t, ', InOutRes=', InOutRes);
@ -88,8 +119,14 @@ end;
function Do_FilePos (Handle: THandle): int64;
var
PosActual: int64;
RC: cardinal;
begin
InOutRes := Sys_DosSetFilePtrL (Handle, 0, 1, PosActual);
RC := Sys_DosSetFilePtrL (Handle, 0, 1, PosActual);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
Do_FilePos := PosActual;
{$ifdef IODEBUG}
writeln('do_filepos: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
@ -99,8 +136,14 @@ end;
procedure Do_Seek (Handle: THandle; Pos: int64);
var
PosActual: int64;
RC: cardinal;
begin
InOutRes:=Sys_DosSetFilePtrL(Handle, Pos, 0 {ZeroBased}, PosActual);
RC := Sys_DosSetFilePtrL(Handle, Pos, 0 {ZeroBased}, PosActual);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
{$ifdef IODEBUG}
writeln('do_seek: handle=', Handle, ', pos=', pos, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
{$endif}
@ -109,9 +152,17 @@ end;
function Do_SeekEnd (Handle: THandle): int64;
var
PosActual: int64;
RC: cardinal;
begin
InOutRes := Sys_DosSetFilePtrL (Handle, 0, 2 {EndBased}, PosActual);
Do_SeekEnd := PosActual;
RC := Sys_DosSetFilePtrL (Handle, 0, 2 {EndBased}, PosActual);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
Do_SeekEnd := -1;
end
else
Do_SeekEnd := PosActual;
{$ifdef IODEBUG}
writeln('do_seekend: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
{$endif}
@ -122,14 +173,25 @@ var
AktFilePos: int64;
begin
AktFilePos := Do_FilePos (Handle);
Do_FileSize := Do_SeekEnd (Handle);
Do_Seek (Handle, AktFilePos);
if InOutRes = 0 then
begin
Do_FileSize := Do_SeekEnd (Handle);
Do_Seek (Handle, AktFilePos);
end;
end;
procedure Do_Truncate (Handle: THandle; Pos: int64);
var
RC: cardinal;
begin
InOutRes := Sys_DosSetFileSizeL (Handle, Pos);
Do_SeekEnd (Handle);
RC := Sys_DosSetFileSizeL (Handle, Pos);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end
else
Do_SeekEnd (Handle);
end;
@ -140,18 +202,23 @@ function Increase_File_Handle_Count: boolean;
var Err: word;
L1: longint;
L2: cardinal;
RC: cardinal;
begin
L1 := 10;
if DosSetRelMaxFH (L1, L2) <> 0 then
Increase_File_Handle_Count := false
RC := DosSetRelMaxFH (L1, L2);
if RC <> 0 then
begin
Increase_File_Handle_Count := false;
OSErrorWatch (RC);
end
else
if L2 > FileHandleCount then
if L2 > FileHandleCount then
begin
FileHandleCount := L2;
Increase_File_Handle_Count := true;
end
else
Increase_File_Handle_Count := false;
else
Increase_File_Handle_Count := false;
end;
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
@ -166,13 +233,13 @@ procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
var
Action, Attrib, OpenFlags, FM: Cardinal;
oldp : pchar;
RC: cardinal;
begin
// close first if opened
if ((flags and $10000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fminput,fmoutput,fminout : Do_Close (FileRec (F).Handle);
fmclosed:;
else
begin
@ -228,14 +295,26 @@ begin
DoDirSeparators(p,pchangeable);
Attrib:=32 {faArchive};
InOutRes:=Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
RC := Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
// If too many open files try to set more file handles and open again
if (InOutRes = 4) then
if Increase_File_Handle_Count then
InOutRes:=Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
If InOutRes<>0 then FileRec(F).Handle:=UnusedHandle;
if Increase_File_Handle_Count then
begin
RC := Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
end;
if RC <> 0 then
FileRec(F).Handle:=UnusedHandle;
// If Handle created -> make some things
if (FileRec(F).Handle <> UnusedHandle) then
@ -261,9 +340,16 @@ end;
function do_isdevice (Handle: THandle): boolean;
var
HT, Attr: cardinal;
RC: cardinal;
begin
do_isdevice:=false;
If DosQueryHType(Handle, HT, Attr)<>0 then exit;
if ht=1 then do_isdevice:=true;
RC := DosQueryHType(Handle, HT, Attr);
if RC <> 0 then
begin
OSErrorWatch (RC);
Exit;
end;
if ht=1 then
do_isdevice:=true;
end;
{$ASMMODE ATT}

17
rtl/os2/sysheap.inc
View File

@ -1,10 +1,8 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
Copyright (c) 2001-2014 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
This file implements heap management for OS/2.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -87,6 +85,7 @@ begin
else
begin
SysOSAlloc := nil;
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW}
if Int_HeapSize <> high (cardinal) then
begin
@ -104,25 +103,23 @@ end;
{$define HAS_SYSOSFREE}
procedure SysOSFree (P: pointer; Size: ptruint);
{$IFDEF EXTDUMPGROW}
var
RC: cardinal;
{$ENDIF EXTDUMPGROW}
begin
{$IFDEF EXTDUMPGROW}
WriteLn ('Trying to free memory!');
WriteLn ('Total allocated memory is ', Int_HeapSize);
Dec (Int_HeapSize, Size);
RC :=
{$ENDIF EXTDUMPGROW}
DosFreeMem (P);
{$IFDEF EXTDUMPGROW}
RC := DosFreeMem (P);
if RC <> 0 then
begin
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW}
WriteLn ('Error ', RC, ' during memory deallocation (DosFreeMem)!');
WriteLn ('Total allocated memory is ', Int_HeapSize);
end;
{$ENDIF EXTDUMPGROW}
end;
end;

10
rtl/os2/sysos.inc
View File

@ -54,7 +54,7 @@ type
var
ProcessID: SizeUInt;
function GetProcessID:SizeUInt;
function GetProcessID: SizeUInt;
begin
GetProcessID := ProcessID;
end;
@ -420,3 +420,11 @@ external 'DOSCALLS' index 306;
function DosQuerySysInfo (First, Last: cardinal; var Buf; BufSize: cardinal):
cardinal; cdecl;
external 'DOSCALLS' index 348;
type
TCPArray = array [0..2] of cardinal;
PCPArray = ^TCPArray;
function DosQueryCP (Size: cardinal; CodePages: PCPArray;
var ActSize: cardinal): cardinal; cdecl;
external 'DOSCALLS' index 291;

197
rtl/os2/system.pas
View File

@ -110,6 +110,20 @@ const
(* Are file sizes > 2 GB (64-bit) supported on the current system? *)
FSApi64: boolean = false;
(* Support for tracking I/O errors returned by OS/2 API calls - emulation *)
(* of GetLastError / fpGetError functionality used e.g. in Sysutils. *)
type
TOSErrorWatch = procedure (Error: cardinal);
procedure NoErrorTracking (Error: cardinal);
(* This shall be invoked whenever a non-zero error is returned by OS/2 APIs *)
(* used in the RTL. Direct OS/2 API calls in user programs are not covered! *)
const
OSErrorWatch: TOSErrorWatch = @NoErrorTracking;
procedure SetOSErrorTracking (P: pointer);
procedure SetDefaultOS2FileType (FType: ShortString);
@ -174,12 +188,15 @@ function Is_Prefetch (P: pointer): boolean;
InstrLo, InstrHi, OpCode: byte;
I: longint;
MemSize, MemAttrs: cardinal;
RC: cardinal;
begin
Is_Prefetch := false;
MemSize := SizeOf (A);
if (DosQueryMem (P, MemSize, MemAttrs) = 0) and
(MemAttrs and (mfPag_Free or mfPag_Commit) <> 0)
RC := DosQueryMem (P, MemSize, MemAttrs);
if RC <> 0 then
OSErrorWatch (RC)
else if (MemAttrs and (mfPag_Free or mfPag_Commit) <> 0)
and (MemSize >= SizeOf (A)) then
Move (P^, A [0], SizeOf (A))
else
@ -289,6 +306,7 @@ var
Res: cardinal;
Err: byte;
Must_Reset_FPU: boolean;
RC: cardinal;
{$IFDEF SYSTEMEXCEPTIONDEBUG}
CurSS: cardinal;
B: byte;
@ -382,7 +400,9 @@ begin
{$ENDIF SYSTEMEXCEPTIONDEBUG}
Report^.Exception_Num := 0;
Res := Xcpt_Continue_Execution;
DosAcknowledgeSignalException (Report^.Parameters [0]);
RC := DosAcknowledgeSignalException (Report^.Parameters [0]);
if RC <> 0 then
OSErrorWatch (RC);
end
else
Err := 217;
@ -443,7 +463,9 @@ begin
{$ENDIF SYSTEMEXCEPTIONDEBUG}
Report^.Exception_Num := 0;
Res := Xcpt_Continue_Execution;
DosAcknowledgeSignalException (Report^.Parameters [0]);
RC := DosAcknowledgeSignalException (Report^.Parameters [0]);
if RC <> 0 then
OSErrorWatch (RC);
end
else
Err := 217;
@ -504,6 +526,7 @@ var
procedure Install_Exception_Handler;
var
T: cardinal;
RC: cardinal;
begin
{$ifdef SYSTEMEXCEPTIONDEBUG}
(* ThreadInfoBlock is located at FS:[0], the first *)
@ -524,9 +547,15 @@ begin
DosSetExceptionHandler (ExcptReg^);
if IsConsole then
begin
DosSetSignalExceptionFocus (1, T);
DosAcknowledgeSignalException (Xcpt_Signal_Intr);
DosAcknowledgeSignalException (Xcpt_Signal_Break);
RC := DosSetSignalExceptionFocus (1, T);
if RC <> 0 then
OSErrorWatch (RC);
RC := DosAcknowledgeSignalException (Xcpt_Signal_Intr);
if RC <> 0 then
OSErrorWatch (RC);
RC := DosAcknowledgeSignalException (Xcpt_Signal_Break);
if RC <> 0 then
OSErrorWatch (RC);
end;
{$ifdef SYSTEMEXCEPTIONDEBUG}
asm
@ -538,8 +567,10 @@ begin
end;
procedure Remove_Exception_Handlers;
var
RC: cardinal;
begin
DosUnsetExceptionHandler (ExcptReg^);
RC := DosUnsetExceptionHandler (ExcptReg^);
end;
{$ENDIF OS2EXCEPTIONS}
@ -686,6 +717,10 @@ begin
end;
procedure SysInitStdIO;
(*
var
RC: cardinal;
*)
begin
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
displayed in a messagebox }
@ -695,21 +730,36 @@ begin
StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
if not IsConsole then
begin
if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and
(DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0)
and
(DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0)
and
(DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue))
= 0)
then
begin
begin
RC := DosLoadModule (nil, 0, 'PMWIN', PMWinHandle);
if RC <> 0 then
OSErrorWatch (RC)
else
begin
RC := DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox));
if RC <> 0 then
OSErrorWatch (RC)
else
begin
RC := DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize));
if RC <> 0 then
OSErrorWatch (RC)
else
begin
RC := DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue));
if RC <> 0 then
OSErrorWatch (RC)
else
begin
WinInitialize (0);
WinCreateMsgQueue (0, 0);
end
else
HandleError (2);
end
end
end
end;
if RC <> 0 then
HandleError (2);
AssignError (StdErr);
AssignError (StdOut);
Assign (Output, '');
@ -824,6 +874,21 @@ begin
end;
(* The default handler does not store the OS/2 API error codes. *)
procedure NoErrorTracking (Error: cardinal);
begin
end;
procedure SetOSErrorTracking (P: pointer);
begin
if P = nil then
OSErrorWatch := @NoErrorTracking
else
OSErrorWatch := TOSErrorWatch (P);
end;
procedure InitEnvironment;
var env_count : longint;
dos_env,cp : pchar;
@ -870,6 +935,7 @@ var
pc,arg : pchar;
quote : char;
argvlen : PtrInt;
RC: cardinal;
procedure allocarg(idx,len: PtrInt);
var
@ -896,7 +962,8 @@ begin
ArgLen := StrLen (PChar (PIB^.Cmd));
Inc (ArgLen);
if DosQueryModuleName (PIB^.Handle, MaxPathLen, CmdLine) = 0 then
RC := DosQueryModuleName (PIB^.Handle, MaxPathLen, CmdLine);
if RC = 0 then
ArgVLen := Succ (StrLen (CmdLine))
else
(* Error occurred - use program name from command line as fallback. *)
@ -1070,10 +1137,17 @@ end;
function GetFileHandleCount: longint;
var L1: longint;
L2: cardinal;
RC: cardinal;
begin
L1 := 0; (* Don't change the amount, just check. *)
if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
else GetFileHandleCount := L2;
RC := DosSetRelMaxFH (L1, L2);
if RC <> 0 then
begin
GetFileHandleCount := 50;
OSErrorWatch (RC);
end
else
GetFileHandleCount := L2;
end;
function CheckInitialStkLen (StkLen: SizeUInt): SizeUInt;
@ -1086,6 +1160,8 @@ var TIB: PThreadInfoBlock;
ErrStr: string;
P: pointer;
DW: cardinal;
CPArr: TCPArray;
ReturnedSize: cardinal;
const
DosCallsName: array [0..8] of char = 'DOSCALLS'#0;
@ -1094,29 +1170,9 @@ const
{$I sysucode.inc}
{$ENDIF OS2UNICODE}
{*var}
{* ST: pointer;}
{*}
begin
{$IFDEF OS2EXCEPTIONS}
(* asm
{ allocate space for exception registration record }
pushl $0
pushl $0}
{* pushl %fs:(0)}
{ movl %esp,%fs:(0)
but don't insert it as it doesn't
point to anything yet
this will be used in signals unit }
movl %esp,%eax
movl %eax,ExcptReg
pushl %ebp
movl %esp,%eax
{* movl %eax,st*}
movl %eax,StackTop
end;
{* StackTop:=st;}
*) asm
asm
xorl %eax,%eax
movw %ss,%ax
movl %eax,_SS
@ -1166,24 +1222,28 @@ begin
from the high memory region before changing value of this variable. *)
InitHeap;
if DosQueryModuleHandle (@DosCallsName [0], DosCallsHandle) = 0 then
begin
if DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P) = 0 then
begin
Sys_DosOpenL := TDosOpenL (P);
if DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P) = 0
then
begin
Sys_DosSetFilePtrL := TDosSetFilePtrL (P);
if DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil,
P) = 0 then
begin
Sys_DosSetFileSizeL := TDosSetFileSizeL (P);
FSApi64 := true;
end;
end;
end;
end;
RC := DosQueryModuleHandle (@DosCallsName [0], DosCallsHandle);
if RC = 0 then
begin
RC := DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P);
if RC = 0 then
begin
Sys_DosOpenL := TDosOpenL (P);
RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P);
if RC = 0 then
begin
Sys_DosSetFilePtrL := TDosSetFilePtrL (P);
RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil, P);
if RC = 0 then
begin
Sys_DosSetFileSizeL := TDosSetFileSizeL (P);
FSApi64 := true;
end;
end;
end;
end;
if RC <> 0 then
OSErrorWatch (RC);
{ ... and exceptions }
SysInitExceptions;
@ -1220,4 +1280,15 @@ begin
WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8),
', new exception ', HexStr (NewExceptAddr, 8), ', _SS = ', HexStr (_SS, 8));
{$endif SYSTEMEXCEPTIONDEBUG}
RC := DosQueryCP (SizeOf (CPArr), @CPArr, ReturnedSize);
if RC <> 0 then
OSErrorWatch (RC)
else if (ReturnedSize >= 4) then
begin
DefaultSystemCodePage := CPArr [0];
DefaultRTLFileSystemCodePage := DefaultSystemCodePage;
DefaultFileSystemCodePage := DefaultSystemCodePage;
DefaultUnicodeCodePage := CP_UTF16;
end;
end.

192
rtl/os2/systhrd.inc
View File

@ -195,15 +195,21 @@ end;
procedure SysAllocateThreadVars;
var
RC: cardinal;
begin
{ we've to allocate the memory from the OS }
{ because the FPC heap management uses }
{ exceptions which use threadvars but }
{ these aren't allocated yet ... }
{ allocate room on the heap for the thread vars }
if DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write
or pag_Commit) <> 0 then
HandleError (8);
RC := DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write
or pag_Commit);
if RC <> 0 then
begin
OSErrorWatch (RC);
HandleError (8);
end;
{ The Windows API apparently provides a way to fill the allocated memory with }
{ zeros; we probably need to do it ourselves for compatibility. }
FillChar (DataIndex^^, 0, ThreadVarBlockSize);
@ -240,12 +246,16 @@ end;
procedure SysFiniMultithreading;
var
RC: cardinal;
begin
if IsMultiThread then
begin
if DosFreeThreadLocalMemory (DataIndex) <> 0 then
RC := DosFreeThreadLocalMemory (DataIndex);
if RC <> 0 then
begin
{??? What to do if releasing fails?}
OSErrorWatch (RC);
end;
DataIndex := nil;
end;
@ -253,9 +263,13 @@ end;
procedure SysReleaseThreadVars;
var
RC: cardinal;
begin
DosFreeMem (DataIndex^);
DataIndex^ := nil;
RC := DosFreeMem (DataIndex^);
if RC <> 0 then
OSErrorWatch (RC);
DataIndex^ := nil;
end;
@ -334,6 +348,7 @@ function SysBeginThread (SA: pointer; StackSize : PtrUInt;
CreationFlags: cardinal; var ThreadId: TThreadID): DWord;
var
TI: PThreadInfo;
RC: cardinal;
begin
{ WriteLn is not a good idea before thread initialization...
$ifdef DEBUG_MT
@ -351,8 +366,9 @@ begin
{$ifdef DEBUG_MT}
WriteLn ('Starting new thread');
{$endif DEBUG_MT}
if DosCreateThread (cardinal (ThreadID), @ThreadMain, TI,
CreationFlags, StackSize) = 0 then
RC := DosCreateThread (cardinal (ThreadID), @ThreadMain, TI,
CreationFlags, StackSize);
if RC = 0 then
SysBeginThread := ThreadID
else
begin
@ -361,6 +377,7 @@ begin
WriteLn ('Thread creation failed');
{$ENDIF DEBUG_MT}
Dispose (TI);
OSErrorWatch (RC);
end;
end;
@ -379,40 +396,62 @@ end;
function SysSuspendThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin
{$WARNING Check expected return value}
SysSuspendThread := DosSuspendThread (ThreadHandle);
RC := DosSuspendThread (ThreadHandle);
SysSuspendThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end;
function SysResumeThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin
{$WARNING Check expected return value}
SysResumeThread := DosResumeThread (ThreadHandle);
RC := DosResumeThread (ThreadHandle);
SysResumeThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end;
function SysKillThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin
SysKillThread := DosKillThread (ThreadHandle);
RC := DosKillThread (ThreadHandle);
SysKillThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end;
{$PUSH}
{$WARNINGS OFF}
function SysCloseThread (ThreadHandle: TThreadID): dword;
begin
{ Probably not relevant under OS/2? }
// SysCloseThread:=CloseHandle(threadHandle);
end;
{$POP}
function SysWaitForThreadTerminate (ThreadHandle: dword;
TimeoutMs: longint): dword;
var
RC: cardinal;
RC, RC2: cardinal;
const
{ Wait at most 100 ms before next check for thread termination }
WaitTime = 100;
begin
if TimeoutMs = 0 then
RC := DosWaitThread (ThreadHandle, dcWW_Wait)
begin
RC := DosWaitThread (ThreadHandle, dcWW_Wait);
if RC <> 0 then
OSErrorWatch (RC);
end
else
repeat
RC := DosWaitThread (ThreadHandle, dcWW_NoWait);
@ -423,10 +462,14 @@ begin
else
begin
DosSleep (TimeoutMs);
DosWaitThread (ThreadHandle, dcWW_NoWait);
RC2 := DosWaitThread (ThreadHandle, dcWW_NoWait);
if RC2 <> 0 then
OSErrorWatch (RC2);
end;
Dec (TimeoutMs, WaitTime);
end;
end
else if RC <> 0 then
OSErrorWatch (RC);
until (RC <> 294) or (TimeoutMs <= 0);
SysWaitForThreadTerminate := RC;
end;
@ -451,7 +494,9 @@ begin
else
begin
RC := DosQuerySysState (qs_Process, 0, ProcessID, 0, PPtrRec^, BufSize);
if (RC = 0) and (PPtrRec^.PProcRec <> nil)
if RC <> 0 then
OSErrorWatch (RC)
else if (PPtrRec^.PProcRec <> nil)
and (PPtrRec^.PProcRec^.PThrdRec <> nil) then
begin
BufEnd := PtrUInt (PPtrRec) + BufSize;
@ -480,6 +525,7 @@ function SysThreadSetPriority (ThreadHandle: dword; Prio: longint): boolean;
var
Delta: longint;
Priority: cardinal;
RC: cardinal;
begin
Priority := GetOS2ThreadPriority (ThreadHandle);
if Priority > High (word) then
@ -491,8 +537,10 @@ begin
Delta := - TPrio (Priority).PrioLevel
else if Delta + TPrio (Priority).PrioLevel > 31 then
Delta := 31 - TPrio (Priority).PrioLevel;
SysThreadSetPriority :=
DosSetPriority (dpThread, dpSameClass, Delta, ThreadHandle) = 0;
RC := DosSetPriority (dpThread, dpSameClass, Delta, ThreadHandle);
if RC <> 0 then
OSErrorWatch (RC);
SysThreadSetPriority := RC = 0;
end;
end;
@ -529,25 +577,43 @@ end;
*****************************************************************************}
procedure SysInitCriticalSection (var CS);
var
RC: cardinal;
begin
if DosCreateMutExSem (nil, THandle (CS), 0, 0) <> 0 then
FPC_ThreadError;
RC := DosCreateMutExSem (nil, THandle (CS), 0, 0);
if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end;
procedure SysDoneCriticalSection (var CS);
var
RC: cardinal;
begin
(* Trying to release first since this might apparently be the expected *)
(* behaviour in Delphi according to comment in the Unix implementation. *)
repeat
until DosReleaseMutExSem (THandle (CS)) <> 0;
if DosCloseMutExSem (THandle (CS)) <> 0 then
FPC_ThreadError;
RC := DosCloseMutExSem (THandle (CS));
if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end;
procedure SysEnterCriticalSection (var CS);
var
RC: cardinal;
begin
if DosRequestMutExSem (THandle (CS), cardinal (-1)) <> 0 then
FPC_ThreadError;
RC := DosRequestMutExSem (THandle (CS), cardinal (-1));
if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end;
function SysTryEnterCriticalSection (var CS): longint;
@ -559,9 +625,15 @@ begin
end;
procedure SysLeaveCriticalSection (var CS);
var
RC: cardinal;
begin
if DosReleaseMutExSem (THandle (CS)) <> 0 then
FPC_ThreadError;
RC := DosReleaseMutExSem (THandle (CS));
if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end;
@ -607,18 +679,23 @@ begin
if RC <> 0 then
begin
Dispose (PLocalEventRec (Result));
OSErrorWatch (RC);
FPC_ThreadError;
end;
end;
procedure SysBasicEventDestroy (State: PEventState);
var
RC: cardinal;
begin
if State = nil then
FPC_ThreadError
else
begin
DosCloseEventSem (PLocalEventRec (State)^.FHandle);
RC := DosCloseEventSem (PLocalEventRec (State)^.FHandle);
if RC <> 0 then
OSErrorWatch (RC);
Dispose (PLocalEventRec (State));
end;
end;
@ -627,22 +704,33 @@ end;
procedure SysBasicEventResetEvent (State: PEventState);
var
PostCount: cardinal;
RC: cardinal;
begin
if State = nil then
FPC_ThreadError
else
begin
(* In case of later addition of error checking: *)
(* RC 300 = Error_Already_Reset which would be OK. *)
DosResetEventSem (PLocalEventRec (State)^.FHandle, PostCount);
RC := DosResetEventSem (PLocalEventRec (State)^.FHandle, PostCount);
if (RC <> 0) and (RC <> 300) then
OSErrorWatch (RC);
end;
end;
procedure SysBasicEventSetEvent (State: PEventState);
var
RC: cardinal;
begin
if State = nil then
FPC_ThreadError
else
DosPostEventSem (PLocalEventRec (State)^.FHandle);
begin
RC := DosPostEventSem (PLocalEventRec (State)^.FHandle);
if RC <> 0 then
OSErrorWatch (RC);
end;
end;
@ -661,6 +749,7 @@ begin
else
begin
Result := wrError;
OSErrorWatch (RC);
PLocalEventRec (State)^.FLastError := RC;
end;
end;
@ -669,41 +758,64 @@ end;
function SysRTLEventCreate: PRTLEvent;
var
RC: cardinal;
begin
Result := PRTLEvent (-1);
DosCreateEventSem (nil, THandle (Result), dce_AutoReset, 0);
RC := DosCreateEventSem (nil, THandle (Result), dce_AutoReset, 0);
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure SysRTLEventDestroy (AEvent: PRTLEvent);
var
RC: cardinal;
begin
DosCloseEventSem (THandle (AEvent));
RC := DosCloseEventSem (THandle (AEvent));
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure SysRTLEventSetEvent (AEvent: PRTLEvent);
var
RC: cardinal;
begin
DosPostEventSem (THandle (AEvent));
RC := DosPostEventSem (THandle (AEvent));
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure SysRTLEventWaitFor (AEvent: PRTLEvent);
var
RC: cardinal;
begin
DosWaitEventSem (THandle (AEvent), cardinal (-1));
RC := DosWaitEventSem (THandle (AEvent), cardinal (-1));
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure SysRTLEventWaitForTimeout (AEvent: PRTLEvent; Timeout: longint);
var
RC: cardinal;
begin
DosWaitEventSem (THandle (AEvent), Timeout);
RC := DosWaitEventSem (THandle (AEvent), Timeout);
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure SysRTLEventResetEvent (AEvent: PRTLEvent);
var
PostCount: cardinal;
RC: cardinal;
begin
DosResetEventSem (THandle (AEvent), PostCount);
RC := DosResetEventSem (THandle (AEvent), PostCount);
if RC <> 0 then
OSErrorWatch (RC);
end;
@ -713,11 +825,15 @@ const
svNumProcessors = 26;
var
ProcNum: cardinal;
RC: cardinal;
begin
GetCPUCount := 1;
if DosQuerySysInfo (svNumProcessors, svNumProcessors, ProcNum,
SizeOf (ProcNum)) = 0 then
GetCPUCount := ProcNum;
RC := DosQuerySysInfo (svNumProcessors, svNumProcessors, ProcNum,
SizeOf (ProcNum));
if RC = 0 then
GetCPUCount := ProcNum
else
OSErrorWatch (RC);
end;

391
rtl/os2/sysutils.pp
View File

@ -23,6 +23,7 @@ interface
{$H+}
{$DEFINE HAS_SLEEP}
{$DEFINE HAS_OSERROR}
{ used OS file system APIs use ansistring }
{$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL}
@ -83,8 +84,11 @@ begin
If Rc=0 then
FileOpen:=Handle
else
begin
FileOpen:=feInvalidHandle; //FileOpen:=-RC;
//should return feInvalidHandle(=-1) if fail, other negative returned value are no more errors
OSErrorWatch (RC);
end;
end;
function FileCreate (const FileName: RawByteString): THandle;
@ -115,56 +119,84 @@ begin
if RC = 0 then
FileCreate := Handle
else
FileCreate := feInvalidHandle;
begin
FileCreate := feInvalidHandle;
OSErrorWatch (RC);
end;
End;
function FileRead (Handle: THandle; Out Buffer; Count: longint): longint;
Var
T: cardinal;
RC: cardinal;
begin
DosRead(Handle, Buffer, Count, T);
RC := DosRead (Handle, Buffer, Count, T);
FileRead := longint (T);
if RC <> 0 then
OSErrorWatch (RC);
end;
function FileWrite (Handle: THandle; const Buffer; Count: longint): longint;
Var
T: cardinal;
RC: cardinal;
begin
DosWrite (Handle, Buffer, Count, T);
RC := DosWrite (Handle, Buffer, Count, T);
FileWrite := longint (T);
if RC <> 0 then
OSErrorWatch (RC);
end;
function FileSeek (Handle: THandle; FOffset, Origin: longint): longint;
var
NPos: int64;
RC: cardinal;
begin
if (Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos) = 0)
and (NPos < high (longint)) then
RC := Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos);
if (RC = 0) and (NPos < high (longint)) then
FileSeek:= longint (NPos)
else
begin
FileSeek:=-1;
OSErrorWatch (RC);
end;
end;
function FileSeek (Handle: THandle; FOffset: Int64; Origin: Longint): Int64;
var
NPos: int64;
RC: cardinal;
begin
if Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos) = 0 then
RC := Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos);
if RC = 0 then
FileSeek:= NPos
else
begin
FileSeek:=-1;
OSErrorWatch (RC);
end;
end;
procedure FileClose (Handle: THandle);
var
RC: cardinal;
begin
DosClose(Handle);
RC := DosClose (Handle);
if RC <> 0 then
OSErrorWatch (RC);
end;
function FileTruncate (Handle: THandle; Size: Int64): boolean;
var
RC: cardinal;
begin
FileTruncate:=Sys_DosSetFileSizeL(Handle, Size)=0;
FileSeek(Handle, 0, 2);
RC := Sys_DosSetFileSizeL(Handle, Size);
FileTruncate := RC = 0;
if RC = 0 then
FileSeek(Handle, 0, 2)
else
OSErrorWatch (RC);
end;
function FileAge (const FileName: RawByteString): longint;
@ -222,7 +254,9 @@ begin
else
Err := DosFindFirst (PChar (SystemEncodedPath), Rslt.FindHandle,
Attr and FindResvdMask, FStat, SizeOf (FStat^), Count, ilStandard);
if (Err = 0) and (Count = 0) then
if Err <> 0 then
OSErrorWatch (Err)
else if Count = 0 then
Err := 18;
InternalFindFirst := -Err;
if Err = 0 then
@ -261,7 +295,9 @@ begin
New (FStat);
Count := 1;
Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat^), Count);
if (Err = 0) and (Count = 0) then
if Err <> 0 then
OSErrorWatch (Err)
else if Count = 0 then
Err := 18;
InternalFindNext := -Err;
if Err = 0 then
@ -290,9 +326,12 @@ end;
Procedure InternalFindClose(var Handle: THandle);
var
SR: PSearchRec;
RC: cardinal;
begin
DosFindClose (Handle);
RC := DosFindClose (Handle);
Handle := 0;
if RC <> 0 then
OSErrorWatch (RC);
end;
function FileGetDate (Handle: THandle): longint;
@ -308,7 +347,10 @@ begin
if Time = 0 then
Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16;
end else
begin
Time:=0;
OSErrorWatch (RC);
end;
FileGetDate:=Time;
end;
@ -320,19 +362,25 @@ begin
New (FStat);
RC := DosQueryFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
begin
FileSetDate := -1;
OSErrorWatch (RC);
end
else
begin
begin
FStat^.DateLastAccess := Hi (Age);
FStat^.DateLastWrite := Hi (Age);
FStat^.TimeLastAccess := Lo (Age);
FStat^.TimeLastWrite := Lo (Age);
RC := DosSetFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
begin
FileSetDate := -1;
OSErrorWatch (RC);
end
else
FileSetDate := 0;
end;
FileSetDate := 0;
end;
Dispose (FStat);
end;
@ -340,11 +388,18 @@ function FileGetAttr (const FileName: RawByteString): longint;
var
FS: PFileStatus3;
SystemFileName: RawByteString;
RC: cardinal;
begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
New(FS);
Result:=-DosQueryPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^));
If Result=0 Then Result:=FS^.attrFile;
RC := DosQueryPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^));
if RC = 0 then
Result := FS^.AttrFile
else
begin
Result := - longint (RC);
OSErrorWatch (RC);
end;
Dispose(FS);
end;
@ -352,12 +407,16 @@ function FileSetAttr (const Filename: RawByteString; Attr: longint): longint;
Var
FS: PFileStatus3;
SystemFileName: RawByteString;
RC: cardinal;
Begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
New(FS);
FillChar(FS, SizeOf(FS^), 0);
FS^.AttrFile:=Attr;
Result:=-DosSetPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^), 0);
RC := DosSetPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^), 0);
if RC <> 0 then
OSErrorWatch (RC);
Result := - longint (RC);
Dispose(FS);
end;
@ -365,18 +424,34 @@ end;
function DeleteFile (const FileName: RawByteString): boolean;
var
SystemFileName: RawByteString;
RC: cardinal;
Begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
Result:=(DosDelete(PChar (SystemFileName))=0);
RC := DosDelete (PChar (SystemFileName));
if RC <> 0 then
begin
Result := false;
OSErrorWatch (RC);
end
else
Result := true;
End;
function RenameFile (const OldName, NewName: RawByteString): boolean;
var
OldSystemFileName, NewSystemFileName: RawByteString;
RC: cardinal;
Begin
OldSystemFileName:=ToSingleByteFileSystemEncodedFileName(OldName);
NewSystemFileName:=ToSingleByteFileSystemEncodedFileName(NewName);
Result:=(DosMove(PChar (OldSystemFileName), PChar (NewSystemFileName))=0);
RC := DosMove (PChar (OldSystemFileName), PChar (NewSystemFileName));
if RC <> 0 then
begin
Result := false;
OSErrorWatch (RC);
end
else
Result := true;
End;
{****************************************************************************
@ -389,13 +464,16 @@ var FI: TFSinfo;
RC: cardinal;
begin
{In OS/2, we use the filesystem information.}
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) *
{In OS/2, we use the filesystem information.}
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskFree := -1;
else
begin
DiskFree := -1;
OSErrorWatch (RC);
end;
end;
function DiskSize (Drive: byte): int64;
@ -404,13 +482,16 @@ var FI: TFSinfo;
RC: cardinal;
begin
{In OS/2, we use the filesystem information.}
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) *
{In OS/2, we use the filesystem information.}
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskSize := -1;
else
begin
DiskSize := -1;
OSErrorWatch (RC);
end;
end;
@ -469,17 +550,21 @@ end;
procedure sysbeep;
begin
// Maybe implement later on ?
DosBeep (800, 250);
end;
{****************************************************************************
Locale Functions
****************************************************************************}
var
Country: TCountryCode;
CtryInfo: TCountryInfo;
procedure InitAnsi;
var I: byte;
Country: TCountryCode;
var
I: byte;
RC: cardinal;
begin
for I := 0 to 255 do
UpperCaseTable [I] := Chr (I);
@ -493,46 +578,63 @@ end;
procedure InitInternational;
var Country: TCountryCode;
CtryInfo: TCountryInfo;
Size: cardinal;
RC: cardinal;
var
Size: cardinal;
RC: cardinal;
begin
Size := 0;
FillChar (Country, SizeOf (Country), 0);
FillChar (CtryInfo, SizeOf (CtryInfo), 0);
RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
if RC = 0 then
begin
DateSeparator := CtryInfo.DateSeparator;
case CtryInfo.DateFormat of
1: begin
ShortDateFormat := 'd/m/y';
LongDateFormat := 'dd" "mmmm" "yyyy';
end;
2: begin
ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
Size := 0;
FillChar (Country, SizeOf (Country), 0);
FillChar (CtryInfo, SizeOf (CtryInfo), 0);
RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
if RC = 0 then
begin
DateSeparator := CtryInfo.DateSeparator;
case CtryInfo.DateFormat of
1: begin
ShortDateFormat := 'd/m/y';
LongDateFormat := 'dd" "mmmm" "yyyy';
end;
InitAnsi;
InitInternationalGeneric;
2: begin
ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
end
else
OSErrorWatch (RC);
InitAnsi;
InitInternationalGeneric;
end;
function SysErrorMessage(ErrorCode: Integer): String;
const
SysMsgFile: array [0..10] of char = 'OSO001.MSG'#0;
var
OutBuf: array [0..999] of char;
RetMsgSize: cardinal;
RC: cardinal;
begin
Result:=Format(SUnknownErrorCode,[ErrorCode]);
RC := DosGetMessage (nil, 0, @OutBuf [0], SizeOf (OutBuf),
ErrorCode, @SysMsgFile [0], RetMsgSize);
if RC = 0 then
begin
SetLength (Result, RetMsgSize);
Move (OutBuf [0], Result [1], RetMsgSize);
end
else
begin
Result:=Format(SUnknownErrorCode,[ErrorCode]);
OSErrorWatch (RC);
end;
end;
@ -687,7 +789,10 @@ begin
SD.ObjectBuffLen := ObjBufSize;
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
if RC <> 0 then
Move (QName [1], ObjNameBuf^, Length (QName))
begin
Move (QName [1], ObjNameBuf^, Length (QName));
OSErrorWatch (RC);
end
else
begin
RC := DosStartSession (SD, SID, PID);
@ -697,15 +802,28 @@ begin
if RC = 0 then
begin
Result := PCI^.Return;
DosCloseQueue (HQ);
DosFreeMem (PCI);
RC := DosCloseQueue (HQ);
if RC <> 0 then
OSErrorWatch (RC);
RC := DosFreeMem (PCI);
if RC <> 0 then
OSErrorWatch (RC);
FreeMem (ObjNameBuf, ObjBufSize);
end
else
DosCloseQueue (HQ);
begin
OSErrorWatch (RC);
RC := DosCloseQueue (HQ);
OSErrorWatch (RC);
end;
end
else
DosCloseQueue (HQ);
begin
OSErrorWatch (RC);
RC := DosCloseQueue (HQ);
if RC <> 0 then
OSErrorWatch (RC);
end;
end;
end;
@ -715,52 +833,57 @@ begin
GetMem (ObjNameBuf, ObjBufSize);
FillChar (ObjNameBuf^, ObjBufSize, 0);
if (DosQueryAppType (PChar (Path), ExecAppType) = 0) and
(ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *)
RC := DosQueryAppType (PChar (Path), ExecAppType);
if RC <> 0 then
begin
if ComLine = '' then
begin
Args0 := nil;
Args := nil;
end
else
begin
GetMem (Args0, MaxArgsSize);
Args := Args0;
(* Work around a bug in OS/2 - argument to DosExecPgm *)
(* should not cross 64K boundary. *)
if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
Inc (pointer (Args), 1024);
ArgSize := 0;
Move (Path [1], Args^ [ArgSize], Length (Path));
Inc (ArgSize, Length (Path));
Args^ [ArgSize] := 0;
Inc (ArgSize);
{Now do the real arguments.}
Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
Inc (ArgSize, Length (ComLine));
Args^ [ArgSize] := 0;
Inc (ArgSize);
Args^ [ArgSize] := 0;
end;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjNameBuf, ObjBufSize, 0, Args, nil, Res, PChar (Path));
if Args0 <> nil then
FreeMem (Args0, MaxArgsSize);
if RC = 0 then
begin
Result := Res.ExitCode;
FreeMem (ObjNameBuf, ObjBufSize);
end
else
begin
if (RC = 190) or (RC = 191) then
Result := StartSession;
end;
OSErrorWatch (RC);
if (RC = 190) or (RC = 191) then
Result := StartSession;
end
else
Result := StartSession;
begin
if (ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *)
begin
if ComLine = '' then
begin
Args0 := nil;
Args := nil;
end
else
begin
GetMem (Args0, MaxArgsSize);
Args := Args0;
(* Work around a bug in OS/2 - argument to DosExecPgm *)
(* should not cross 64K boundary. *)
if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
Inc (pointer (Args), 1024);
ArgSize := 0;
Move (Path [1], Args^ [ArgSize], Length (Path));
Inc (ArgSize, Length (Path));
Args^ [ArgSize] := 0;
Inc (ArgSize);
{Now do the real arguments.}
Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
Inc (ArgSize, Length (ComLine));
Args^ [ArgSize] := 0;
Inc (ArgSize);
Args^ [ArgSize] := 0;
end;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjNameBuf, ObjBufSize, 0, Args, nil, Res,
PChar (Path));
if RC <> 0 then
OSErrorWatch (RC);
if Args0 <> nil then
FreeMem (Args0, MaxArgsSize);
if RC = 0 then
begin
Result := Res.ExitCode;
FreeMem (ObjNameBuf, ObjBufSize);
end
end
end;
if RC <> 0 then
begin
ObjName := StrPas (ObjNameBuf);
@ -805,16 +928,33 @@ begin
GetTickCount := L;
end;
function GetTickCount64: QWord;
var
L: cardinal;
Freq2: cardinal;
T: QWord;
begin
DosQuerySysInfo (svMsCount, svMsCount, L, 4);
GetTickCount64 := L;
DosTmrQueryFreq (Freq2);
DosTmrQueryTime (T);
GetTickCount64 := T div (QWord (Freq2) div 1000);
{$NOTE GetTickCount64 takes 20 microseconds on 1GHz CPU, GetTickCount not measurable}
end;
threadvar
LastOSError: cardinal;
const
OrigOSErrorWatch: TOSErrorWatch = nil;
procedure TrackLastOSError (Error: cardinal);
begin
LastOSError := Error;
OrigOSErrorWatch (Error);
end;
function GetLastOSError: Integer;
begin
GetLastOSError := Integer (LastOSError);
end;
{****************************************************************************
Initialization code
@ -824,6 +964,9 @@ Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
OnBeep:=@SysBeep;
LastOSError := 0;
OrigOSErrorWatch := OSErrorWatch;
SetOSErrorTracking (@TrackLastOSError);
Finalization
DoneExceptions;
end.

11
rtl/os2/tthread.inc
View File

@ -166,13 +166,16 @@ procedure TThread.SetPriority(Value: TThreadPriority);
var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
RC: cardinal;
begin
DosGetInfoBlocks (@PTIB, @PPIB);
(*
PTIB^.TIB2^.Priority := Priorities [Value];
*)
DosSetPriority (2, High (Priorities [Value]),
RC := DosSetPriority (2, High (Priorities [Value]),
Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);
if RC <> 0 then
OSErrorWatch (RC);
end;
@ -213,9 +216,13 @@ end;
function TThread.WaitFor: Integer;
var
FH: cardinal;
RC: cardinal;
begin
if GetCurrentThreadID = MainThreadID then
while not (FFinished) do
CheckSynchronize (1000);
WaitFor := DosWaitThread (FH, dtWait);
RC := DosWaitThread (FH, dtWait);
if RC <> 0 then
OSErrorWatch (RC);
WaitFor := RC;
end;