{ This file is part of the Free Pascal run time library. Copyright (c) 2001-2015 by Free Pascal development team This file contains a subset of OS/2 base types and imported OS/2 API functions necessary for implementation of unit system. 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. **********************************************************************} type TByteArray = array [0..$FFFF] of byte; PByteArray = ^TByteArray; TSysThreadIB = record TID, Priority, Version: cardinal; MCCount, MCForceFlag: word; end; PSysThreadIB = ^TSysThreadIB; TThreadInfoBlock = record PExChain, Stack, StackLimit: pointer; TIB2: PSysThreadIB; Version, Ordinal: cardinal; end; PThreadInfoBlock = ^TThreadInfoBlock; PPThreadInfoBlock = ^PThreadInfoBlock; TProcessInfoBlock = record PID, ParentPid, Handle: cardinal; Cmd, Env: PByteArray; Status, ProcType: cardinal; end; PProcessInfoBlock = ^TProcessInfoBlock; PPProcessInfoBlock = ^PProcessInfoBlock; var ProcessID: SizeUInt; function GetProcessID: SizeUInt; begin GetProcessID := ProcessID; end; type TSysDateTime=packed record Hour, Minute, Second, Sec100, Day, Month: byte; Year: word; TimeZone: smallint; WeekDay: byte; end; procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock; PAPIB: PPProcessInfoBlock); cdecl; external 'DOSCALLS' index 312; function DosLoadModule (ObjName: PAnsiChar; ObjLen: cardinal; DLLName: PAnsiChar; var Handle: THandle): cardinal; cdecl; external 'DOSCALLS' index 318; function DosFreeModule (Handle: THandle): cardinal; cdecl; external 'DOSCALLS' index 322; function DosQueryModuleHandle (DLLName: PAnsiChar; var Handle: THandle): cardinal; cdecl; external 'DOSCALLS' index 319; function DosQueryProcAddr (Handle, Ordinal: cardinal; ProcName: PAnsiChar; var Address: pointer): cardinal; cdecl; external 'DOSCALLS' index 321; function DosSetRelMaxFH (var ReqCount: longint; var CurMaxFH: cardinal): cardinal; cdecl; external 'DOSCALLS' index 382; function DosSetCurrentDir (Name:PAnsiChar): cardinal; cdecl; external 'DOSCALLS' index 255; procedure DosQueryCurrentDisk(var DiskNum:cardinal;var Logical:cardinal); cdecl; external 'DOSCALLS' index 275; function DosSetDefaultDisk (DiskNum:cardinal): cardinal; cdecl; external 'DOSCALLS' index 220; { This is not real prototype, but is close enough } { for us (the 2nd parameter is actually a pointer } { to a structure). } function DosCreateDir (Name: PAnsiChar; P: pointer): cardinal; cdecl; external 'DOSCALLS' index 270; function DosDeleteDir (Name: PAnsiChar): cardinal; cdecl; external 'DOSCALLS' index 226; function DosQueryCurrentDir(DiskNum:cardinal;var Buffer; var BufLen:cardinal): cardinal; cdecl; external 'DOSCALLS' index 274; function DosMove(OldFile,NewFile:PAnsiChar):cardinal; cdecl; external 'DOSCALLS' index 271; function DosDelete(FileName:PAnsiChar):cardinal; cdecl; external 'DOSCALLS' index 259; procedure DosExit(Action, Result: cardinal); cdecl; external 'DOSCALLS' index 234; // EAs not used in System unit function DosOpen(FileName:PAnsiChar;var Handle: THandle;var Action:cardinal; InitSize,Attrib,OpenFlags,FileMode:cardinal; EA:Pointer): cardinal; cdecl; external 'DOSCALLS' index 273; function DosClose(Handle: THandle): cardinal; cdecl; external 'DOSCALLS' index 257; function DosRead(Handle: THandle; Buffer: Pointer; Count: cardinal; var ActCount: cardinal): cardinal; cdecl; external 'DOSCALLS' index 281; function DosWrite(Handle: THandle; Buffer: Pointer;Count: cardinal; var ActCount: cardinal): cardinal; cdecl; external 'DOSCALLS' index 282; function DosSetFilePtr(Handle: THandle; Pos:longint; Method:cardinal; var PosActual: cardinal): cardinal; cdecl; external 'DOSCALLS' index 256; function DosSetFileSize(Handle: THandle; Size: cardinal): cardinal; cdecl; external 'DOSCALLS' index 272; function DosQueryHType(Handle: THandle; var HandType: cardinal; var Attr: cardinal): cardinal; cdecl; external 'DOSCALLS' index 224; function DosQueryModuleName (Handle: THandle; NameLen: cardinal; Name: PAnsiChar): cardinal; cdecl; external 'DOSCALLS' index 320; function DosGetDateTime(var Buf:TSysDateTime): cardinal; cdecl; external 'DOSCALLS' index 230; { Already declared in interface part: type TDosOpenL = function (FileName: PAnsiChar; var Handle: THandle; var Action: cardinal; InitSize: int64; Attrib, OpenFlags, FileMode: cardinal; EA: pointer): cardinal; cdecl; TDosSetFilePtrL = function (Handle: THandle; Pos: int64; Method: cardinal; var PosActual: int64): cardinal; cdecl; TDosSetFileSizeL = function (Handle: THandle; Size: int64): cardinal; cdecl; } function DummyDosOpenL (FileName: PAnsiChar; var Handle: THandle; var Action: cardinal; InitSize: int64; Attrib, OpenFlags, FileMode: cardinal; EA: pointer): cardinal; cdecl; begin DummyDosOpenL := DosOpen (FileName, Handle, Action, InitSize, Attrib, OpenFlags, FileMode, EA); end; function DummyDosSetFilePtrL (Handle: THandle; Pos: int64; Method: cardinal; var PosActual: int64): cardinal; cdecl; var PosAct0: cardinal; begin DummyDosSetFilePtrL := DosSetFilePtr (Handle, Pos, Method, PosAct0); PosActual := PosAct0; end; function DummyDosSetFileSizeL (Handle: THandle; Size: int64): cardinal; cdecl; begin DummyDosSetFileSizeL := DosSetFileSize (Handle, Size); end; const OrdDosOpenL = 981; OrdDosSetFilePtrL = 988; OrdDosSetFileSizeL = 989; { converts an OS/2 error code to a TP compatible error } { code. Same thing exists under most other supported } { systems. } { Only call for OS/2 DLL imported routines } Procedure Errno2InOutRes; Begin { errors 1..18 are the same as in DOS } case InOutRes of { simple offset to convert these error codes } { exactly like the error codes in Win32 } 19..31 : InOutRes := InOutRes + 131; { gets a bit more complicated ... } 32..33 : InOutRes := 5; 38 : InOutRes := 100; 39 : InOutRes := 101; 112 : InOutRes := 101; 110 : InOutRes := 5; 114 : InOutRes := 6; 206 : InOutRes := 3; (* TH: Path too long *) 290 : InOutRes := 4; end; { all other cases ... we keep the same error code } end; (* Types and constants for exception handler support *) const deHardErr = 1; {Pop-ups for hard errors are enabled, to disable do not give this switch.} deDisableExceptions = 2; {Pop-ups for exceptions are disabled, to enable do not give this switch.} MaxExceptionParameters = 4; {Enough for all system exceptions.} Xcpt_Continue_Search = $00000000; Xcpt_Continue_Execution = $ffffffff; Xcpt_Continue_Stop = $00716668; Xcpt_Signal_Intr = 1; Xcpt_Signal_KillProc = 3; Xcpt_Signal_Break = 4; Xcpt_Fatal_Exception = $c0000000; Xcpt_Severity_Code = $c0000000; Xcpt_Customer_Code = $20000000; Xcpt_Facility_Code = $1fff0000; Xcpt_Exception_Code = $0000ffff; Xcpt_Unknown_Access = $00000000; Xcpt_Read_Access = $00000001; Xcpt_Write_Access = $00000002; Xcpt_Execute_Access = $00000004; Xcpt_Space_Access = $00000008; Xcpt_Limit_Access = $00000010; Xcpt_Data_Unknown = $ffffffff; Xcpt_Guard_Page_Violation = $80000001; Xcpt_Unable_To_Grow_Stack = $80010001; Xcpt_Access_Violation = $c0000005; Xcpt_In_Page_Error = $c0000006; Xcpt_Illegal_Instruction = $c000001c; Xcpt_Invalid_Lock_Sequence = $c000001d; Xcpt_Noncontinuable_Exception = $c0000024; Xcpt_Invalid_Disposition = $c0000025; Xcpt_Unwind = $c0000026; Xcpt_Bad_Stack = $c0000027; Xcpt_Invalid_Unwind_Target = $c0000028; Xcpt_Array_Bounds_Exceeded = $c0000093; Xcpt_Float_Denormal_Operand = $c0000094; Xcpt_Float_Divide_By_Zero = $c0000095; Xcpt_Float_Inexact_Result = $c0000096; Xcpt_Float_Invalid_Operation = $c0000097; Xcpt_Float_Overflow = $c0000098; Xcpt_Float_Stack_Check = $c0000099; Xcpt_Float_Underflow = $c000009a; Xcpt_Integer_Divide_By_Zero = $c000009b; Xcpt_Integer_Overflow = $c000009c; Xcpt_Privileged_Instruction = $c000009d; Xcpt_Datatype_Misalignment = $c000009e; Xcpt_Breakpoint = $c000009f; Xcpt_Single_Step = $c00000a0; Xcpt_Process_Terminate = $c0010001; Xcpt_Async_Process_Terminate = $c0010002; Xcpt_Signal = $c0010003; Context_Control = $00000001; { SS:ESP, CS:EIP, EFLAGS and EBP set } Context_Integer = $00000002; { EAX, EBX, ECX, EDX, ESI and EDI set } Context_Segments = $00000004; { DS, ES, FS, and GS set } Context_Floating_Point = $00000008; { numeric coprocessor state set } Context_Full = Context_Control or Context_Integer or Context_Segments or Context_Floating_Point; type PExceptionRegistrationRecord = ^TExceptionRegistrationRecord; PExceptionReportRecord = ^TExceptionReportRecord; PContextRecord = ^TContextRecord; TExceptionHandler = function (Report: PExceptionReportRecord; RegRec: PExceptionRegistrationRecord; Context: PContextRecord; DispContext: pointer): cardinal; cdecl; TExceptionRegistrationRecord = record Prev_Structure: PExceptionRegistrationRecord; ExceptionHandler: TExceptionHandler; end; TExceptionReportRecord = record Exception_Num, HandlerFlags: cardinal; Nested_RepRec: PExceptionReportRecord; Address: pointer; ParamCount: cardinal; Parameters: array [0..Pred (MaxExceptionParameters)] of cardinal; end; TContextRecord = packed record ContextFlags: cardinal; Env: array [1..7] of cardinal; FPUStack: array [0..7] of extended; Reg_GS, Reg_FS, Reg_ES, Reg_DS, Reg_EDI, Reg_ESI, Reg_EAX, Reg_EBX, Reg_ECX, Reg_EDX, Reg_EBP, Reg_EIP, Reg_CS, Flags, Reg_ESP, Reg_SS: cardinal; end; function DosSetExceptionHandler (var RegRec: TExceptionRegistrationRecord): cardinal; cdecl; external 'DOSCALLS' index 354; function DosUnsetExceptionHandler (var RegRec: TExceptionRegistrationRecord): cardinal; cdecl; external 'DOSCALLS' index 355; {Full screen applications can get Ctrl-C and Ctrl-Break focus. For all processes sharing one screen, only one can have Ctrl-C focus. Enable = 0 = Release focus, 1 = Get focus. Times = Number of times focus has been get minus number of times it has been released.} function DosSetSignalExceptionFocus (Enable: cardinal; var Times: cardinal): cardinal; cdecl; external 'DOSCALLS' index 378; {Tell we want further signal exceptions. SignalNum = Signal number to acknowlegde.} function DosAcknowledgeSignalException (SignalNum: cardinal): cardinal; cdecl; external 'DOSCALLS' index 418; function DosError (Error: cardinal): cardinal; cdecl; external 'DOSCALLS' index 212; type TWinMessageBox = function (Parent, Owner: cardinal; BoxText, BoxTitle: PAnsiChar; Identity, Style: cardinal): cardinal; cdecl; TWinInitialize = function (Options: cardinal): cardinal; cdecl; TWinCreateMsgQueue = function (Handle: cardinal; cmsg: longint): cardinal; cdecl; const ErrorBufferLength = 1024; mb_OK = $0000; mb_Error = $0040; mb_Moveable = $4000; MBStyle = mb_OK or mb_Error or mb_Moveable; mfPag_Read = $00001; {Give read access to memory.} mfPag_Write = $00002; {Give write access to memory.} mfPag_Execute = $00004; {Allow code execution in memory.} mfPag_Guard = $00008; {Used for dynamic memory growing. Create uncommitted memory and make the first page guarded. Once it is accessed it will be made committed, and the next uncommitted page will be made guarded.} mfPag_Commit = $00010; {Make the memory committed.} mfPag_Decommit = $00020; {Decommit the page.} mfObj_Tile = $00040; {Also allocate 16-bit segments of 64k which map the memory. (Makes 16<>32 bit pointer conversion possible.} mfObj_Protected = $00080; mfObj_Gettable = $00100; mfObj_Giveable = $00200; mfObj_Any = $00400; {Allow using high memory (> 512 MB).} mfPag_Default = $00400; mfPag_Shared = $02000; mfPag_Free = $04000; mfPag_Base = $10000; mfSub_Init = $00001; {Use base, if not set, choose a base address yourself.} mfSub_Grow = $00002; {Grow the specified heap, instead of allocating it. Ignore mfSub_Init.} mfSub_Sparse = $00004; mfSub_Serialize = $00008; function DosQueryMem (P: pointer; var Size, Flag: cardinal): cardinal; cdecl; 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; function DosSetProcessCP (CP: cardinal): cardinal; cdecl; external 'DOSCALLS' index 289; type TCountryCode = record Country, {Country to query info about (0=current).} CodePage: cardinal; {Code page to query info about (0=current).} end; function DosMapCase (Size: cardinal; var Country: TCountryCode; AString: PAnsiChar): cardinal; cdecl; external 'NLS' index 7; function DosQueryDBCSEnv (Size: cardinal; var Country: TCountryCode; Buf: PAnsiChar): cardinal; cdecl; external 'NLS' index 6; function DosQueryCollate (Size: cardinal; var Country: TCountryCode; Buf: PByteArray; var TableLen: cardinal): cardinal; cdecl; external 'NLS' index 8; type TTimeFmt = (Clock12, Clock24); TCountryInfo = record Country, CodePage: cardinal; {Country and codepage requested.} DateFormat: cardinal; {1=ddmmyy 2=yymmdd 3=mmddyy} CurrencyUnit: array [0..4] of AnsiChar; ThousandSeparator: AnsiChar; {Thousands separator.} Zero1: byte; {Always zero.} DecimalSeparator: AnsiChar; {Decimals separator,} Zero2: byte; DateSeparator: AnsiChar; {Date separator.} Zero3: byte; TimeSeparator: AnsiChar; {Time separator.} Zero4: byte; CurrencyFormat, {Bit field: Bit 0: 0=indicator before value 1=indicator after value Bit 1: 1=insert space after indicator. Bit 2: 1=Ignore bit 0&1, replace decimal separator with indicator.} DecimalPlace: byte; {Number of decimal places used in currency indication.} TimeFormat: TTimeFmt; {12/24 hour.} Reserve1: array [0..1] of word; DataSeparator: AnsiChar; {Data list separator} Zero5: byte; Reserve2: array [0..4] of word; end; const CurrentCountry: TCountryCode = (Country: 0; CodePage: 0); function DosQueryCtryInfo (Size: cardinal; var Country: TCountryCode; var Res: TCountryInfo; var ActualSize: cardinal): cardinal; cdecl; external 'NLS' index 5; type PInsertTable = ^TInsertTable; TInsertTable = array [1..9] of PAnsiChar; function DosTrueGetMessage (MsgSeg: pointer; Table: PInsertTable; TableSize: cardinal; Buf: PAnsiChar; BufSize, MsgNumber: cardinal; FileName: PAnsiChar; var MsgSize: cardinal): cardinal; cdecl; external 'MSG' index 6; procedure MagicHeaderEnd; assembler; forward; {$ASMMODE INTEL} {start of _MSGSEG32 segment} procedure MagicHeaderStart; assembler; asm db $0FF db $4D,$53,$47,$53,$45,$47,$33,$32, 0 //'MSGSEG32' dd $8001 dd MagicHeaderEnd end; function DosGetMessage (Table: PInsertTable; TableSize: cardinal; Buf: PAnsiChar; BufSize, MsgNumber: cardinal; FileName: PAnsiChar; var MsgSize: cardinal): cardinal; cdecl; assembler; nostackframe; asm pop eax push offset MagicHeaderStart push eax jmp DosTrueGetMessage end; procedure MagicHeaderEnd; assembler; asm dd $0FFFF0000 end; {$ASMMODE DEFAULT}