paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-05 11:52:33 +02:00
Code Issues Packages Projects Releases Wiki Activity
e2904b82a1
fpc/rtl/win32/syswin32.pp
peter e2904b82a1 * fixes for smartlinking
1998-12-28 23:30:11 +00:00

1068 lines
28 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
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.
**********************************************************************}
{$S-}
unit syswin32;
{$I os.inc}
interface
{ include system-independent routine headers }
{$I systemh.inc}
{ include heap support headers }
{$I heaph.inc}
{$ifdef i386}
{$define Set_i386_Exception_handler}
{$endif i386}
const
{ Default filehandles }
UnusedHandle : longint = -1;
StdInputHandle : longint = 0;
StdOutputHandle : longint = 0;
StdErrorHandle : longint = 0;
type
TStartupInfo=packed record
cb : longint;
lpReserved : Pointer;
lpDesktop : Pointer;
lpTitle : Pointer;
dwX : longint;
dwY : longint;
dwXSize : longint;
dwYSize : longint;
dwXCountChars : longint;
dwYCountChars : longint;
dwFillAttribute : longint;
dwFlags : longint;
wShowWindow : Word;
cbReserved2 : Word;
lpReserved2 : Pointer;
hStdInput : longint;
hStdOutput : longint;
hStdError : longint;
end;
var
{ C compatible arguments }
argc : longint;
argv : ppchar;
{ Win32 Info }
startupinfo : tstartupinfo;
hprevinst,
HInstance,
MainInstance,
cmdshow : longint;
IsLibrary,IsMultiThreaded,IsConsole : boolean;
DLLreason,DLLparam:longint;
implementation
{ include system independent routines }
{$I system.inc}
{ some declarations for Win32 API calls }
{$I win32.inc}
CONST
{ These constants are used for conversion of error codes }
{ from win32 i/o errors to tp i/o errors }
{ errors 1 to 18 are the same as in Turbo Pascal }
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING! }
{ The media is write protected. }
ERROR_WRITE_PROTECT = 19;
{ The system cannot find the device specified. }
ERROR_BAD_UNIT = 20;
{ The device is not ready. }
ERROR_NOT_READY = 21;
{ The device does not recognize the command. }
ERROR_BAD_COMMAND = 22;
{ Data error (cyclic redundancy check) }
ERROR_CRC = 23;
{ The program issued a command but the }
{ command length is incorrect. }
ERROR_BAD_LENGTH = 24;
{ The drive cannot locate a specific }
{ area or track on the disk. }
ERROR_SEEK = 25;
{ The specified disk or diskette cannot be accessed. }
ERROR_NOT_DOS_DISK = 26;
{ The drive cannot find the sector requested. }
ERROR_SECTOR_NOT_FOUND = 27;
{ The printer is out of paper. }
ERROR_OUT_OF_PAPER = 28;
{ The system cannot write to the specified device. }
ERROR_WRITE_FAULT = 29;
{ The system cannot read from the specified device. }
ERROR_READ_FAULT = 30;
{ A device attached to the system is not functioning.}
ERROR_GEN_FAILURE = 31;
{ The process cannot access the file because }
{ it is being used by another process. }
ERROR_SHARING_VIOLATION = 32;
var
errno : longint;
{ misc. functions }
function GetLastError : DWORD;
external 'kernel32' name 'GetLastError';
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
external 'user32' name 'MessageBoxA';
{ time and date functions }
function GetTickCount : longint;
external 'kernel32' name 'GetTickCount';
{ process functions }
procedure ExitProcess(uExitCode : UINT);
external 'kernel32' name 'ExitProcess';
Procedure Errno2InOutRes;
Begin
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
if (errno >= ERROR_WRITE_PROTECT) and (errno <= ERROR_GEN_FAILURE) THEN
BEGIN
{ This is the offset to the Win32 to add to directly map }
{ to the DOS/TP compatible error codes when in this range }
InOutRes := word(errno)+131;
END
else
{ This case is special }
if errno=ERROR_SHARING_VIOLATION THEN
BEGIN
InOutRes :=5;
END
else
{ other error codes can directly be mapped }
InOutRes := Word(errno);
errno:=0;
end;
{$ifdef dummy}
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
{
called when trying to get local stack if the compiler directive $S
is set this function must preserve esi !!!! because esi is set by
the calling proc for methods it must preserve all registers !!
With a 2048 byte safe area used to write to StdIo without crossing
the stack boundary
}
begin
asm
pushl %eax
pushl %ebx
movl stack_size,%ebx
addl $2048,%ebx
movl %esp,%eax
subl %ebx,%eax
movl stacklimit,%ebx
cmpl %eax,%ebx
jae __short_on_stack
popl %ebx
popl %eax
leave
ret $4
__short_on_stack:
{ can be usefull for error recovery !! }
popl %ebx
popl %eax
end['EAX','EBX'];
HandleError(202);
end;
{$endif dummy}
procedure halt(errnum : byte);
begin
do_exit;
ExitProcess(errnum);
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
if (l>=0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure randomize;
begin
randseed:=GetTickCount;
end;
{*****************************************************************************
Heap Management
*****************************************************************************}
{ memory functions }
function GlobalAlloc(mode,size:longint):longint;
external 'kernel32' name 'GlobalAlloc';
function GlobalLock(handle:longint):pointer;
external 'kernel32' name 'GlobalLock';
{$ifdef SYSTEMDEBUG}
function GlobalSize(h:longint):longint;
external 'kernel32' name 'GlobalSize';
{$endif}
{$ASMMODE DIRECT}
function getheapstart:pointer;assembler;
asm
leal HEAP,%eax
end ['EAX'];
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
{$ASMMODE ATT}
function Sbrk(size : longint):longint;
var
h,l : longint;
begin
h:=GlobalAlloc(258,size);
l:=longint(GlobalLock(h));
if l=0 then
l:=-1;
{$ifdef SYSTEMDEBUG}
Writeln('new heap part at $',hexstr(l,8), ' size = ',GlobalSize(h));
{$endif}
sbrk:=l;
end;
{ include standard heap management }
{$I heap.inc}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
external 'kernel32' name 'WriteFile';
function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
external 'kernel32' name 'ReadFile';
function CloseHandle(h : longint) : longint;
external 'kernel32' name 'CloseHandle';
function DeleteFile(p : pchar) : longint;
external 'kernel32' name 'DeleteFileA';
function MoveFile(old,_new : pchar) : longint;
external 'kernel32' name 'MoveFileA';
function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint;
external 'kernel32' name 'SetFilePointer';
function GetFileSize(h:longint;p:pointer) : longint;
external 'kernel32' name 'GetFileSize';
function CreateFile(name : pointer;access,sharing : longint;
security : pointer;how,attr,template : longint) : longint;
external 'kernel32' name 'CreateFileA';
function SetEndOfFile(h : longint) : longbool;
external 'kernel32' name 'SetEndOfFile';
function GetFileType(Handle:DWORD):DWord;
external 'kernel32' name 'GetFileType';
procedure AllowSlash(p:pchar);
var
i : longint;
begin
{ allow slash as backslash }
for i:=0 to strlen(p) do
if p[i]='/' then p[i]:='\';
end;
procedure do_close(h : longint);
begin
closehandle(h);
end;
procedure do_erase(p : pchar);
begin
AllowSlash(p);
if DeleteFile(p)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
procedure do_rename(p1,p2 : pchar);
begin
AllowSlash(p1);
AllowSlash(p2);
if MoveFile(p1,p2)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_write(h,addr,len : longint) : longint;
var
size:longint;
begin
if writefile(h,pointer(addr),len,size,nil)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
do_write:=size;
end;
function do_read(h,addr,len : longint) : longint;
var
result:longint;
begin
if readfile(h,pointer(addr),len,result,nil)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
do_read:=result;
end;
function do_filepos(handle : longint) : longint;
var
l:longint;
begin
l:=SetFilePointer(handle,0,nil,FILE_CURRENT);
if l=-1 then
begin
l:=0;
errno:=GetLastError;
Errno2InoutRes;
end;
do_filepos:=l;
end;
procedure do_seek(handle,pos : longint);
begin
if SetFilePointer(handle,pos,nil,FILE_BEGIN)=-1 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_seekend(handle:longint):longint;
begin
do_seekend:=SetFilePointer(handle,0,nil,FILE_END);
if do_seekend=-1 then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_filesize(handle : longint) : longint;
var
aktfilepos : longint;
begin
aktfilepos:=do_filepos(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,aktfilepos);
end;
procedure do_truncate (handle,pos:longint);
begin
do_seek(handle,pos);
if not(SetEndOfFile(handle)) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
procedure do_open(var f;p : pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $10) the file will be append
when (flags and $100) the file will be truncate/rewritten
when (flags and $1000) there is no check for close (needed for textfiles)
}
var
oflags,cd : longint;
begin
AllowSlash(p);
{ close first if opened }
if ((flags and $1000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fmclosed : ;
else
begin
{not assigned}
inoutres:=102;
exit;
end;
end;
end;
{ reset file handle }
filerec(f).handle:=UnusedHandle;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : begin
filerec(f).mode:=fminput;
oflags:=GENERIC_READ;
end;
1 : begin
filerec(f).mode:=fmoutput;
oflags:=GENERIC_WRITE;
end;
2 : begin
filerec(f).mode:=fminout;
oflags:=GENERIC_WRITE or GENERIC_READ;
end;
end;
{ standard is opening and existing file }
cd:=OPEN_EXISTING;
{ create it ? }
if (flags and $100)<>0 then
cd:=CREATE_ALWAYS
{ or append ? }
else
if (flags and $10)<>0 then
cd:=OPEN_ALWAYS;
{ empty name is special }
if p[0]=#0 then
begin
case filerec(f).mode of
fminput : filerec(f).handle:=StdInputHandle;
fmappend,
fmoutput : begin
filerec(f).handle:=StdOutputHandle;
filerec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
filerec(f).handle:=CreateFile(p,oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0);
{ append mode }
if (flags and $10)<>0 then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
{ get errors }
if (filerec(f).handle=0) or (filerec(f).handle=-1) then
{ handle -1 is returned sometimes !! (PM) }
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_isdevice(handle:longint):boolean;
begin
do_isdevice:=(getfiletype(handle)=2);
end;
{*****************************************************************************
UnTyped File Handling
*****************************************************************************}
{$i file.inc}
{*****************************************************************************
Typed File Handling
*****************************************************************************}
{$i typefile.inc}
{*****************************************************************************
Text File Handling
*****************************************************************************}
{$DEFINE EOF_CTRLZ}
{$i text.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
function CreateDirectory(name : pointer;sec : pointer) : longint;
external 'kernel32' name 'CreateDirectoryA';
function RemoveDirectory(name:pointer):longint;
external 'kernel32' name 'RemoveDirectoryA';
function SetCurrentDirectory(name : pointer) : longint;
external 'kernel32' name 'SetCurrentDirectoryA';
function GetCurrentDirectory(bufsize : longint;name : pchar) : longint;
external 'kernel32' name 'GetCurrentDirectoryA';
type
TDirFnType=function(name:pointer):word;
procedure dirfn(afunc : TDirFnType;const s:string);
var
buffer : array[0..255] of char;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
AllowSlash(pchar(@buffer));
if aFunc(@buffer)=0 then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function CreateDirectoryTrunc(name:pointer):word;
begin
CreateDirectoryTrunc:=CreateDirectory(name,nil);
end;
procedure mkdir(const s:string);[IOCHECK];
begin
If InOutRes <> 0 then exit;
dirfn(TDirFnType(@CreateDirectoryTrunc),s);
end;
procedure rmdir(const s:string);[IOCHECK];
begin
If InOutRes <> 0 then exit;
dirfn(TDirFnType(@RemoveDirectory),s);
end;
procedure chdir(const s:string);[IOCHECK];
begin
If InOutRes <> 0 then exit;
dirfn(TDirFnType(@SetCurrentDirectory),s);
end;
procedure getdir(drivenr:byte;var dir:shortstring);
const
Drive:array[0..3]of char=(#0,':',#0,#0);
var
defaultdrive:boolean;
DirBuf,SaveBuf:array[0..259] of Char;
begin
defaultdrive:=drivenr=0;
if not defaultdrive then
begin
byte(Drive[0]):=Drivenr+64;
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
SetCurrentDirectory(@Drive);
end;
GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
if not defaultdrive then
SetCurrentDirectory(@SaveBuf);
dir:=strpas(DirBuf);
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
{ Startup }
procedure GetStartupInfo(p : pointer);
external 'kernel32' name 'GetStartupInfoA';
function GetStdHandle(nStdHandle:DWORD):THANDLE;
external 'kernel32' name 'GetStdHandle';
{ command line/enviroment functions }
function GetCommandLine : pchar;
external 'kernel32' name 'GetCommandLineA';
{ module functions }
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
external 'kernel32' name 'GetModuleFileNameA';
function GetModuleHandle(p : pointer) : longint;
external 'kernel32' name 'GetModuleHandleA';
var
ModuleName : array[0..255] of char;
function GetCommandFile:pchar;
begin
GetModuleFileName(0,@ModuleName,255);
GetCommandFile:=@ModuleName;
end;
procedure setup_arguments;
var
arglen,
count : longint;
argstart,
cmdline : pchar;
quote : set of char;
argsbuf : array[0..127] of pchar;
begin
{ create commandline, it starts with the executed filename which is argv[0] }
cmdline:=GetCommandLine;
count:=0;
repeat
{ skip leading spaces }
while cmdline^ in [' ',#9,#13] do
inc(longint(cmdline));
case cmdline^ of
#0 : break;
'"' : begin
quote:=['"'];
inc(longint(cmdline));
end;
'''' : begin
quote:=[''''];
inc(longint(cmdline));
end;
else
quote:=[' ',#9,#13];
end;
{ scan until the end of the argument }
argstart:=cmdline;
while (cmdline^<>#0) and not(cmdline^ in quote) do
inc(longint(cmdline));
{ reserve some memory }
arglen:=cmdline-argstart;
getmem(argsbuf[count],arglen+1);
move(argstart^,argsbuf[count]^,arglen);
argsbuf[count][arglen]:=#0;
{ skip quote }
if cmdline^ in quote then
inc(longint(cmdline));
inc(count);
until false;
{ create argc }
argc:=count;
{ create an nil entry }
argsbuf[count]:=nil;
inc(count);
{ create the argv }
getmem(argv,count shl 2);
move(argsbuf,argv^,count shl 2);
end;
{$ifdef dummy}
Function SetUpStack : longint;
{ This routine does the following : }
{ returns the value of the initial SP - __stklen }
begin
asm
pushl %ebx
pushl %eax
movl __stklen,%ebx
movl %esp,%eax
subl %ebx,%eax
movl %eax,__RESULT
popl %eax
popl %ebx
end;
end;
{$endif}
procedure install_exception_handlers;forward;
var
{ value of the stack segment
to check if the call stack can be written on exceptions }
_SS : longint;
procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
begin
IsLibrary:=false;
{ install the handlers for exe only ?
or should we install them for DLL also ? (PM) }
install_exception_handlers;
{ This strange construction is needed to solve the _SS problem
with a smartlinked syswin32 (PFV) }
{$ASMMODE ATT}
asm
pushl %ebp
xorl %ebp,%ebp
movw %ss,%bp
movl %ebp,_SS
xorl %ebp,%ebp
end;
{$ASMMODE DIRECT}
asm
call PASCALMAIN
popl %ebp
end;
{ if we pass here there was no error ! }
ExitProcess(0);
end;
procedure Dll_entry;[public, alias : '_FPC_DLL_Entry'];
begin
IsLibrary:=true;
case DLLreason of
1,2 :
begin
{$ASMMODE ATT}
asm
xorl %edi,%edi
movw %ss,%di
movl %edi,_SS
end;
{$ASMMODE DIRECT}
asm
call PASCALMAIN
end;
end
else
begin
asm
call FPC_DO_EXIT
end;
end;
end;
end;
{$ASMMODE ATT}
{$ifdef Set_i386_Exception_handler}
const
EXCEPTION_MAXIMUM_PARAMETERS = 15;
EXCEPTION_ACCESS_VIOLATION = $c0000005;
EXCEPTION_BREAKPOINT = $80000003;
EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
EXCEPTION_SINGLE_STEP = $80000004;
EXCEPTION_ARRAY_BOUNDS_EXCEEDED = $c000008c;
EXCEPTION_FLT_DENORMAL_OPERAND = $c000008d;
EXCEPTION_FLT_DIVIDE_BY_ZERO = $c000008e;
EXCEPTION_FLT_INEXACT_RESULT = $c000008f;
EXCEPTION_FLT_INVALID_OPERATION = $c0000090;
EXCEPTION_FLT_OVERFLOW = $c0000091;
EXCEPTION_FLT_STACK_CHECK = $c0000092;
EXCEPTION_FLT_UNDERFLOW = $c0000093;
EXCEPTION_INT_DIVIDE_BY_ZERO = $c0000094;
EXCEPTION_INT_OVERFLOW = $c0000095;
EXCEPTION_INVALID_HANDLE = $c0000008;
EXCEPTION_PRIV_INSTRUCTION = $c0000096;
EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
EXCEPTION_NONCONTINUABLE = $1;
EXCEPTION_STACK_OVERFLOW = $c00000fd;
EXCEPTION_INVALID_DISPOSITION = $c0000026;
ExceptionContinueExecution = 0;
ExceptionContinueSearch = 1;
type
FLOATING_SAVE_AREA = record
ControlWord : DWORD;
StatusWord : DWORD;
TagWord : DWORD;
ErrorOffset : DWORD;
ErrorSelector : DWORD;
DataOffset : DWORD;
DataSelector : DWORD;
RegisterArea : array[0..79] of BYTE;
Cr0NpxState : DWORD;
end;
_FLOATING_SAVE_AREA = FLOATING_SAVE_AREA;
TFLOATINGSAVEAREA = FLOATING_SAVE_AREA;
PFLOATINGSAVEAREA = ^FLOATING_SAVE_AREA;
CONTEXT = record
ContextFlags : DWORD;
Dr0 : DWORD;
Dr1 : DWORD;
Dr2 : DWORD;
Dr3 : DWORD;
Dr6 : DWORD;
Dr7 : DWORD;
FloatSave : FLOATING_SAVE_AREA;
SegGs : DWORD;
SegFs : DWORD;
SegEs : DWORD;
SegDs : DWORD;
Edi : DWORD;
Esi : DWORD;
Ebx : DWORD;
Edx : DWORD;
Ecx : DWORD;
Eax : DWORD;
Ebp : DWORD;
Eip : DWORD;
SegCs : DWORD;
EFlags : DWORD;
Esp : DWORD;
SegSs : DWORD;
end;
LPCONTEXT = ^CONTEXT;
_CONTEXT = CONTEXT;
TCONTEXT = CONTEXT;
PCONTEXT = ^CONTEXT;
type pexception_record = ^exception_record;
EXCEPTION_RECORD = record
ExceptionCode : longint;
ExceptionFlags : longint;
ExceptionRecord : pexception_record;
ExceptionAddress : pointer;
NumberParameters : longint;
ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of pointer;
end;
PEXCEPTION_POINTERS = ^EXCEPTION_POINTERS;
EXCEPTION_POINTERS = record
ExceptionRecord : PEXCEPTION_RECORD ;
ContextRecord : PCONTEXT ;
end;
{ type of functions that should be used for exception handling }
LPTOP_LEVEL_EXCEPTION_FILTER = function(excep :PEXCEPTION_POINTERS) : longint;
function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : LPTOP_LEVEL_EXCEPTION_FILTER)
: LPTOP_LEVEL_EXCEPTION_FILTER;
external 'kernel32' name 'SetUnhandledExceptionFilter';
function syswin32_i386_exception_handler(excep :PEXCEPTION_POINTERS) : longint;
var frame : longint;
begin
{ default : unhandled !}
if excep^.ContextRecord^.SegSs=_SS then
frame:=excep^.ContextRecord^.Ebp
else
frame:=0;
syswin32_i386_exception_handler:=ExceptionContinueSearch;
case excep^.ExceptionRecord^.ExceptionCode of
EXCEPTION_ACCESS_VIOLATION :
HandleErrorFrame(216,frame);
{ EXCEPTION_BREAKPOINT = $80000003;
EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
EXCEPTION_SINGLE_STEP = $80000004; }
EXCEPTION_ARRAY_BOUNDS_EXCEEDED :
HandleErrorFrame(201,frame);
{ EXCEPTION_FLT_DENORMAL_OPERAND = $c000008d; }
EXCEPTION_FLT_DIVIDE_BY_ZERO :
HandleErrorFrame(200,frame);
{EXCEPTION_FLT_INEXACT_RESULT = $c000008f;
EXCEPTION_FLT_INVALID_OPERATION = $c0000090;}
EXCEPTION_FLT_OVERFLOW :
HandleErrorFrame(205,frame);
EXCEPTION_FLT_STACK_CHECK :
HandleErrorFrame(207,frame);
{ EXCEPTION_FLT_UNDERFLOW :
HandleErrorFrame(206,frame); should be accepted as zero !! }
EXCEPTION_INT_DIVIDE_BY_ZERO :
HandleErrorFrame(200,frame);
EXCEPTION_INT_OVERFLOW :
HandleErrorFrame(215,frame);
{EXCEPTION_INVALID_HANDLE = $c0000008;
EXCEPTION_PRIV_INSTRUCTION = $c0000096;
EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
EXCEPTION_NONCONTINUABLE = $1;}
EXCEPTION_STACK_OVERFLOW :
HandleErrorFrame(202,frame);
{EXCEPTION_INVALID_DISPOSITION = $c0000026;}
end;
end;
var
old_exception : LPTOP_LEVEL_EXCEPTION_FILTER;
procedure install_exception_handlers;
begin
old_exception:=SetUnhandledExceptionFilter(@syswin32_i386_exception_handler);
end;
{$else not i386 (Processor specific !!)}
procedure install_exception_handlers;
begin
end;
{$endif Set_i386_Exception_handler}
const
Exe_entry_code : pointer = @Exe_entry;
Dll_entry_code : pointer = @Dll_entry;
begin
{ get some helpful informations }
GetStartupInfo(@startupinfo);
{ some misc Win32 stuff }
hprevinst:=0;
if not IsLibrary then
HInstance:=getmodulehandle(GetCommandFile);
MainInstance:=HInstance;
{ No idea how to know this issue !! }
IsMultithreaded:=false;
cmdshow:=startupinfo.wshowwindow;
{ to test stack depth }
loweststack:=maxlongint;
{ real test stack depth }
{ stacklimit := setupstack; }
{ Setup heap }
InitHeap;
{ Setup stdin, stdout and stderr }
StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Arguments }
setup_arguments;
{ Reset IO Error }
InOutRes:=0;
{ Reset internal error variable }
errno := 0;
end.
{
$Log$
Revision 1.32 1998-12-28 23:30:11 peter
* fixes for smartlinking
Revision 1.31 1998/12/28 15:50:51 peter
+ stdout, which is needed when you write something in the system unit
to the screen. Like the runtime error
Revision 1.30 1998/12/21 14:28:23 pierre
* HandleError -> HandleErrorFrame to avoid problem in
assembler code in i386.inc
(call to overloaded function in assembler block !)
Revision 1.29 1998/12/15 22:43:14 peter
* removed temp symbols
Revision 1.28 1998/12/09 17:57:33 pierre
+ exception handling by default
Revision 1.27 1998/12/01 14:00:08 pierre
+ added conversion from exceptions into run time error
(only if syswin32 compiled with -ddebug for now !)
* added HandleErrorFrame(errno,frame)
where you specify the frame
needed for win32 exception handling
Revision 1.26 1998/11/30 13:13:41 pierre
* needs asw to link correctly wprt0 or wdllprt0 file
Revision 1.25 1998/11/30 09:16:58 pierre
+ added the changes from Pavel Ozerski after several modifications
to be able to create DLLs
Revision 1.24 1998/11/16 15:48:54 peter
* fixed longbool returns for api calls
Revision 1.23 1998/11/16 14:14:58 pierre
* changed getdir(byte,string) to getdir(byte,shortstring)
Revision 1.22 1998/10/27 15:07:16 florian
+ Is* flags added
+ IsLibrary works also
Revision 1.21 1998/10/15 16:26:19 peter
+ fpuinit
+ end of backtrace indicator
Revision 1.20 1998/09/14 10:48:33 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.19 1998/09/02 09:03:46 pierre
* do_open sometimes returns -1 as handle on fail
was not checked correctly
Revision 1.16 1998/08/24 14:45:22 pierre
* sbrk was wrong
heap growing now works for win32
Revision 1.15 1998/08/21 10:10:16 peter
* winheap turned off by default
Revision 1.14 1998/07/30 13:27:19 michael
+ Added support for errorproc. Changed runerror to HandleError
Revision 1.13 1998/07/13 21:19:15 florian
* some problems with ansi string support fixed
Revision 1.12 1998/07/07 12:37:28 carl
* correct mapping of error codes for TP compatibility
+ implemented stack checking in ifdef dummy
Revision 1.11 1998/07/02 12:33:18 carl
* IOCheck/InOutRes check for mkdir,rmdir and chdir like in TP
Revision 1.10 1998/07/01 15:30:02 peter
* better readln/writeln
Revision 1.9 1998/06/10 10:39:17 peter
* working w32 rtl
Revision 1.8 1998/06/08 23:07:47 peter
* dos interface is now 100% compatible
* fixed call PASCALMAIN which must be direct asm
Revision 1.7 1998/05/06 12:36:51 michael
+ Removed log from before restored version.
Revision 1.6 1998/04/27 18:29:09 florian
+ do_open implemented, the file-I/O should be now complete
Revision 1.5 1998/04/27 13:58:21 florian
+ paramstr/paramcount implemented
Revision 1.4 1998/04/26 22:37:22 florian
* some small extensions
Revision 1.3 1998/04/26 21:49:57 florian
+ more stuff added (??dir procedures etc.)
}
Reference in New Issue View Git Blame Copy Permalink