← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/win32/system.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/rtl/win32/system.pp
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
    Copyright (c) 1999-2005 by Florian Klaempfl and Pavel Ozerski
 
4
    member of the Free Pascal development team.
 
5
 
 
6
    FPC Pascal system unit for the Win32 API.
 
7
 
 
8
    See the file COPYING.FPC, included in this distribution,
 
9
    for details about the copyright.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
14
 
 
15
 **********************************************************************}
 
16
unit System;
 
17
interface
 
18
 
 
19
{$ifdef SYSTEMDEBUG}
 
20
  {$define SYSTEMEXCEPTIONDEBUG}
 
21
{$endif SYSTEMDEBUG}
 
22
 
 
23
{$ifdef cpui386}
 
24
  {$define Set_i386_Exception_handler}
 
25
{$endif cpui386}
 
26
 
 
27
{$define DISABLE_NO_THREAD_MANAGER}
 
28
 
 
29
{ include system-independent routine headers }
 
30
{$I systemh.inc}
 
31
 
 
32
const
 
33
 LineEnding = #13#10;
 
34
 LFNSupport = true;
 
35
 DirectorySeparator = '\';
 
36
 DriveSeparator = ':';
 
37
 PathSeparator = ';';
 
38
{ FileNameCaseSensitive is defined separately below!!! }
 
39
 maxExitCode = 65535;
 
40
 MaxPathLen = 260;
 
41
 
 
42
type
 
43
   PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
 
44
   TEXCEPTION_FRAME = record
 
45
     next : PEXCEPTION_FRAME;
 
46
     handler : pointer;
 
47
   end;
 
48
 
 
49
const
 
50
{ Default filehandles }
 
51
  UnusedHandle    : THandle = -1;
 
52
  StdInputHandle  : THandle = 0;
 
53
  StdOutputHandle : THandle = 0;
 
54
  StdErrorHandle  : THandle = 0;
 
55
 
 
56
  FileNameCaseSensitive : boolean = true;
 
57
  CtrlZMarksEOF: boolean = true; (* #26 not considered as end of file *)
 
58
 
 
59
  sLineBreak = LineEnding;
 
60
  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
 
61
 
 
62
  { Thread count for DLL }
 
63
  Thread_count : longint = 0;
 
64
  System_exception_frame : PEXCEPTION_FRAME =nil;
 
65
 
 
66
type
 
67
  TStartupInfo=packed record
 
68
    cb : longint;
 
69
    lpReserved : Pointer;
 
70
    lpDesktop : Pointer;
 
71
    lpTitle : Pointer;
 
72
    dwX : longint;
 
73
    dwY : longint;
 
74
    dwXSize : longint;
 
75
    dwYSize : longint;
 
76
    dwXCountChars : longint;
 
77
    dwYCountChars : longint;
 
78
    dwFillAttribute : longint;
 
79
    dwFlags : longint;
 
80
    wShowWindow : Word;
 
81
    cbReserved2 : Word;
 
82
    lpReserved2 : Pointer;
 
83
    hStdInput : longint;
 
84
    hStdOutput : longint;
 
85
    hStdError : longint;
 
86
  end;
 
87
 
 
88
var
 
89
{ C compatible arguments }
 
90
  argc : longint;
 
91
  argv : ppchar;
 
92
{ Win32 Info }
 
93
  startupinfo : tstartupinfo;
 
94
  hprevinst,
 
95
  MainInstance,
 
96
  cmdshow     : longint;
 
97
  DLLreason,DLLparam:longint;
 
98
  StartupConsoleMode : DWORD;
 
99
 
 
100
type
 
101
  TDLL_Process_Entry_Hook = function (dllparam : longint) : longbool;
 
102
  TDLL_Entry_Hook = procedure (dllparam : longint);
 
103
 
 
104
const
 
105
  Dll_Process_Attach_Hook : TDLL_Process_Entry_Hook = nil;
 
106
  Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
 
107
  Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
 
108
  Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
 
109
 
 
110
implementation
 
111
 
 
112
var
 
113
  SysInstance : Longint;public name '_FPC_SysInstance';
 
114
 
 
115
{$ifdef CPUI386}
 
116
{$define HAS_RESOURCES}
 
117
{$i winres.inc}
 
118
{$endif}
 
119
 
 
120
{ used by wstrings.inc because wstrings.inc is included before sysos.inc
 
121
  this is put here (FK) }
 
122
 
 
123
function SysAllocStringLen(psz:pointer;len:dword):pointer;stdcall;
 
124
 external 'oleaut32.dll' name 'SysAllocStringLen';
 
125
 
 
126
procedure SysFreeString(bstr:pointer);stdcall;
 
127
 external 'oleaut32.dll' name 'SysFreeString';
 
128
 
 
129
function SysReAllocStringLen(var bstr:pointer;psz: pointer;
 
130
  len:dword): Integer; stdcall;external 'oleaut32.dll' name 'SysReAllocStringLen';
 
131
 
 
132
 
 
133
{ include system independent routines }
 
134
{$I system.inc}
 
135
 
 
136
{*****************************************************************************
 
137
                              Parameter Handling
 
138
*****************************************************************************}
 
139
 
 
140
var
 
141
  ModuleName : array[0..255] of char;
 
142
 
 
143
function GetCommandFile:pchar;
 
144
begin
 
145
  GetModuleFileName(0,@ModuleName,255);
 
146
  GetCommandFile:=@ModuleName;
 
147
end;
 
148
 
 
149
 
 
150
procedure setup_arguments;
 
151
var
 
152
  arglen,
 
153
  count   : longint;
 
154
  argstart,
 
155
  pc,arg  : pchar;
 
156
  quote   : char;
 
157
  argvlen : longint;
 
158
 
 
159
  procedure allocarg(idx,len:longint);
 
160
    var
 
161
      oldargvlen : longint;
 
162
    begin
 
163
      if idx>=argvlen then
 
164
       begin
 
165
         oldargvlen:=argvlen;
 
166
         argvlen:=(idx+8) and (not 7);
 
167
         sysreallocmem(argv,argvlen*sizeof(pointer));
 
168
         fillchar(argv[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);
 
169
       end;
 
170
      { use realloc to reuse already existing memory }
 
171
      { always allocate, even if length is zero, since }
 
172
      { the arg. is still present!                     }
 
173
      sysreallocmem(argv[idx],len+1);
 
174
    end;
 
175
 
 
176
begin
 
177
  SetupProcVars;
 
178
  { create commandline, it starts with the executed filename which is argv[0] }
 
179
  { Win32 passes the command NOT via the args, but via getmodulefilename}
 
180
  count:=0;
 
181
  argv:=nil;
 
182
  argvlen:=0;
 
183
  pc:=getcommandfile;
 
184
  Arglen:=0;
 
185
  repeat
 
186
    Inc(Arglen);
 
187
  until (pc[Arglen]=#0);
 
188
  allocarg(count,arglen);
 
189
  move(pc^,argv[count]^,arglen+1);
 
190
  { Setup cmdline variable }
 
191
  cmdline:=GetCommandLine;
 
192
  { process arguments }
 
193
  pc:=cmdline;
 
194
{$IfDef SYSTEM_DEBUG_STARTUP}
 
195
  Writeln(stderr,'Win32 GetCommandLine is #',pc,'#');
 
196
{$EndIf }
 
197
  while pc^<>#0 do
 
198
   begin
 
199
     { skip leading spaces }
 
200
     while pc^ in [#1..#32] do
 
201
      inc(pc);
 
202
     if pc^=#0 then
 
203
      break;
 
204
     { calc argument length }
 
205
     quote:=' ';
 
206
     argstart:=pc;
 
207
     arglen:=0;
 
208
     while (pc^<>#0) do
 
209
      begin
 
210
        case pc^ of
 
211
          #1..#32 :
 
212
            begin
 
213
              if quote<>' ' then
 
214
               inc(arglen)
 
215
              else
 
216
               break;
 
217
            end;
 
218
          '"' :
 
219
            if pchar(pc+1)^<>'"' then
 
220
            begin
 
221
              if quote='"' then
 
222
               quote:=' '
 
223
              else
 
224
               quote:='"';
 
225
            end
 
226
            else
 
227
              inc(pc);
 
228
          else
 
229
            inc(arglen);
 
230
        end;
 
231
        inc(pc);
 
232
      end;
 
233
     { copy argument }
 
234
     { Don't copy the first one, it is already there.}
 
235
     If Count<>0 then
 
236
      begin
 
237
        allocarg(count,arglen);
 
238
        quote:=' ';
 
239
        pc:=argstart;
 
240
        arg:=argv[count];
 
241
        while (pc^<>#0) do
 
242
         begin
 
243
           case pc^ of
 
244
             #1..#32 :
 
245
               begin
 
246
                 if quote<>' ' then
 
247
                  begin
 
248
                    arg^:=pc^;
 
249
                    inc(arg);
 
250
                  end
 
251
                 else
 
252
                  break;
 
253
               end;
 
254
             '"' :
 
255
               if pchar(pc+1)^<>'"' then
 
256
                begin
 
257
                  if quote='"' then
 
258
                   quote:=' '
 
259
                  else
 
260
                   quote:='"';
 
261
                end
 
262
               else
 
263
                inc(pc);
 
264
             else
 
265
               begin
 
266
                 arg^:=pc^;
 
267
                 inc(arg);
 
268
               end;
 
269
           end;
 
270
           inc(pc);
 
271
         end;
 
272
        arg^:=#0;
 
273
      end;
 
274
 {$IfDef SYSTEM_DEBUG_STARTUP}
 
275
     Writeln(stderr,'dos arg ',count,' #',arglen,'#',argv[count],'#');
 
276
 {$EndIf SYSTEM_DEBUG_STARTUP}
 
277
     inc(count);
 
278
   end;
 
279
  { get argc and create an nil entry }
 
280
  argc:=count;
 
281
  allocarg(argc,0);
 
282
  { free unused memory }
 
283
  sysreallocmem(argv,(argc+1)*sizeof(pointer));
 
284
end;
 
285
 
 
286
 
 
287
function paramcount : longint;
 
288
begin
 
289
  paramcount := argc - 1;
 
290
end;
 
291
 
 
292
function paramstr(l : longint) : string;
 
293
begin
 
294
  if (l>=0) and (l<argc) then
 
295
    paramstr:=strpas(argv[l])
 
296
  else
 
297
    paramstr:='';
 
298
end;
 
299
 
 
300
 
 
301
procedure randomize;
 
302
begin
 
303
  randseed:=GetTickCount;
 
304
end;
 
305
 
 
306
 
 
307
{*****************************************************************************
 
308
                         System Dependent Exit code
 
309
*****************************************************************************}
 
310
 
 
311
procedure install_exception_handlers;forward;
 
312
procedure remove_exception_handlers;forward;
 
313
procedure PascalMain;stdcall;external name 'PASCALMAIN';
 
314
procedure fpc_do_exit;stdcall;external name 'FPC_DO_EXIT';
 
315
Procedure ExitDLL(Exitcode : longint); forward;
 
316
procedure asm_exit;stdcall;external name 'asm_exit';
 
317
 
 
318
Procedure system_exit;
 
319
begin
 
320
  { don't call ExitProcess inside
 
321
    the DLL exit code !!
 
322
    This crashes Win95 at least PM }
 
323
  if IsLibrary then
 
324
    ExitDLL(ExitCode);
 
325
  if not IsConsole then
 
326
   begin
 
327
     Close(stderr);
 
328
     Close(stdout);
 
329
     Close(erroutput);
 
330
     Close(Input);
 
331
     Close(Output);
 
332
     { what about Input and Output ?? PM }
 
333
     { now handled, FPK }
 
334
   end;
 
335
  remove_exception_handlers;
 
336
 
 
337
  { in 2.0 asm_exit does an exitprocess }
 
338
{$ifndef ver2_0}
 
339
  { do cleanup required by the startup code }
 
340
  asm_exit;
 
341
{$endif ver2_0}
 
342
 
 
343
  { call exitprocess, with cleanup as required }
 
344
  ExitProcess(exitcode);
 
345
end;
 
346
 
 
347
var
 
348
  { value of the stack segment
 
349
    to check if the call stack can be written on exceptions }
 
350
  _SS : Cardinal;
 
351
 
 
352
procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
 
353
  var
 
354
    ST : pointer;
 
355
  begin
 
356
     IsLibrary:=false;
 
357
     { install the handlers for exe only ?
 
358
       or should we install them for DLL also ? (PM) }
 
359
     install_exception_handlers;
 
360
     { This strange construction is needed to solve the _SS problem
 
361
       with a smartlinked syswin32 (PFV) }
 
362
     asm
 
363
         { allocate space for an exception frame }
 
364
        pushl $0
 
365
        pushl %fs:(0)
 
366
        { movl  %esp,%fs:(0)
 
367
          but don't insert it as it doesn't
 
368
          point to anything yet
 
369
          this will be used in signals unit }
 
370
        movl %esp,%eax
 
371
        movl %eax,System_exception_frame
 
372
        pushl %ebp
 
373
        movl %esp,%eax
 
374
        movl %eax,st
 
375
     end;
 
376
     StackTop:=st;
 
377
     asm
 
378
        xorl %eax,%eax
 
379
        movw %ss,%ax
 
380
        movl %eax,_SS
 
381
        call SysResetFPU
 
382
        xorl %ebp,%ebp
 
383
        call PASCALMAIN
 
384
        popl %ebp
 
385
     end;
 
386
     { if we pass here there was no error ! }
 
387
     system_exit;
 
388
  end;
 
389
 
 
390
 
 
391
Const
 
392
  { DllEntryPoint  }
 
393
     DLL_PROCESS_ATTACH = 1;
 
394
     DLL_THREAD_ATTACH = 2;
 
395
     DLL_PROCESS_DETACH = 0;
 
396
     DLL_THREAD_DETACH = 3;
 
397
Var
 
398
     DLLBuf : Jmp_buf;
 
399
Const
 
400
     DLLExitOK : boolean = true;
 
401
 
 
402
function Dll_entry : longbool; [public,alias:'_FPC_DLL_Entry'];
 
403
var
 
404
  res : longbool;
 
405
 
 
406
  begin
 
407
     IsLibrary:=true;
 
408
     Dll_entry:=false;
 
409
     case DLLreason of
 
410
       DLL_PROCESS_ATTACH :
 
411
         begin
 
412
           If SetJmp(DLLBuf) = 0 then
 
413
             begin
 
414
               if assigned(Dll_Process_Attach_Hook) then
 
415
                 begin
 
416
                   res:=Dll_Process_Attach_Hook(DllParam);
 
417
                   if not res then
 
418
                     exit(false);
 
419
                 end;
 
420
               PASCALMAIN;
 
421
               Dll_entry:=true;
 
422
             end
 
423
           else
 
424
             Dll_entry:=DLLExitOK;
 
425
         end;
 
426
       DLL_THREAD_ATTACH :
 
427
         begin
 
428
           inclocked(Thread_count);
 
429
{$warning Allocate Threadvars !}
 
430
           if assigned(Dll_Thread_Attach_Hook) then
 
431
             Dll_Thread_Attach_Hook(DllParam);
 
432
           Dll_entry:=true; { return value is ignored }
 
433
         end;
 
434
       DLL_THREAD_DETACH :
 
435
         begin
 
436
           declocked(Thread_count);
 
437
           if assigned(Dll_Thread_Detach_Hook) then
 
438
             Dll_Thread_Detach_Hook(DllParam);
 
439
{$warning Release Threadvars !}
 
440
           Dll_entry:=true; { return value is ignored }
 
441
         end;
 
442
       DLL_PROCESS_DETACH :
 
443
         begin
 
444
           Dll_entry:=true; { return value is ignored }
 
445
           If SetJmp(DLLBuf) = 0 then
 
446
             FPC_Do_Exit;
 
447
           if assigned(Dll_Process_Detach_Hook) then
 
448
             Dll_Process_Detach_Hook(DllParam);
 
449
         end;
 
450
     end;
 
451
  end;
 
452
 
 
453
Procedure ExitDLL(Exitcode : longint);
 
454
begin
 
455
    DLLExitOK:=ExitCode=0;
 
456
    LongJmp(DLLBuf,1);
 
457
end;
 
458
 
 
459
 
 
460
function GetCurrentProcess : dword;
 
461
 stdcall;external 'kernel32' name 'GetCurrentProcess';
 
462
 
 
463
function ReadProcessMemory(process : dword;address : pointer;dest : pointer;size : dword;bytesread : pdword) :  longbool;
 
464
 stdcall;external 'kernel32' name 'ReadProcessMemory';
 
465
 
 
466
function is_prefetch(p : pointer) : boolean;
 
467
  var
 
468
    a : array[0..15] of byte;
 
469
    doagain : boolean;
 
470
    instrlo,instrhi,opcode : byte;
 
471
    i : longint;
 
472
  begin
 
473
    result:=false;
 
474
    { read memory savely without causing another exeception }
 
475
    if not(ReadProcessMemory(GetCurrentProcess,p,@a,sizeof(a),nil)) then
 
476
      exit;
 
477
    i:=0;
 
478
    doagain:=true;
 
479
    while doagain and (i<15) do
 
480
      begin
 
481
        opcode:=a[i];
 
482
        instrlo:=opcode and $f;
 
483
        instrhi:=opcode and $f0;
 
484
        case instrhi of
 
485
          { prefix? }
 
486
          $20,$30:
 
487
            doagain:=(instrlo and 7)=6;
 
488
          $60:
 
489
            doagain:=(instrlo and $c)=4;
 
490
          $f0:
 
491
            doagain:=instrlo in [0,2,3];
 
492
          $0:
 
493
            begin
 
494
              result:=(instrlo=$f) and (a[i+1] in [$d,$18]);
 
495
              exit;
 
496
            end;
 
497
          else
 
498
            doagain:=false;
 
499
        end;
 
500
        inc(i);
 
501
      end;
 
502
  end;
 
503
 
 
504
 
 
505
//
 
506
// Hardware exception handling
 
507
//
 
508
 
 
509
{$ifdef Set_i386_Exception_handler}
 
510
 
 
511
{
 
512
  Error code definitions for the Win32 API functions
 
513
 
 
514
 
 
515
  Values are 32 bit values layed out as follows:
 
516
   3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
 
517
   1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
 
518
  +---+-+-+-----------------------+-------------------------------+
 
519
  |Sev|C|R|     Facility          |               Code            |
 
520
  +---+-+-+-----------------------+-------------------------------+
 
521
 
 
522
  where
 
523
      Sev - is the severity code
 
524
          00 - Success
 
525
          01 - Informational
 
526
          10 - Warning
 
527
          11 - Error
 
528
 
 
529
      C - is the Customer code flag
 
530
      R - is a reserved bit
 
531
      Facility - is the facility code
 
532
      Code - is the facility's status code
 
533
}
 
534
 
 
535
const
 
536
  SEVERITY_SUCCESS                = $00000000;
 
537
  SEVERITY_INFORMATIONAL  = $40000000;
 
538
  SEVERITY_WARNING                = $80000000;
 
539
  SEVERITY_ERROR                  = $C0000000;
 
540
 
 
541
const
 
542
  STATUS_SEGMENT_NOTIFICATION             = $40000005;
 
543
  DBG_TERMINATE_THREAD                    = $40010003;
 
544
  DBG_TERMINATE_PROCESS                   = $40010004;
 
545
  DBG_CONTROL_C                                   = $40010005;
 
546
  DBG_CONTROL_BREAK                               = $40010008;
 
547
 
 
548
  STATUS_GUARD_PAGE_VIOLATION             = $80000001;
 
549
  STATUS_DATATYPE_MISALIGNMENT    = $80000002;
 
550
  STATUS_BREAKPOINT                               = $80000003;
 
551
  STATUS_SINGLE_STEP                              = $80000004;
 
552
  DBG_EXCEPTION_NOT_HANDLED               = $80010001;
 
553
 
 
554
  STATUS_ACCESS_VIOLATION                 = $C0000005;
 
555
  STATUS_IN_PAGE_ERROR                    = $C0000006;
 
556
  STATUS_INVALID_HANDLE                   = $C0000008;
 
557
  STATUS_NO_MEMORY                                = $C0000017;
 
558
  STATUS_ILLEGAL_INSTRUCTION              = $C000001D;
 
559
  STATUS_NONCONTINUABLE_EXCEPTION = $C0000025;
 
560
  STATUS_INVALID_DISPOSITION              = $C0000026;
 
561
  STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
 
562
  STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
 
563
  STATUS_FLOAT_DIVIDE_BY_ZERO             = $C000008E;
 
564
  STATUS_FLOAT_INEXACT_RESULT             = $C000008F;
 
565
  STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
 
566
  STATUS_FLOAT_OVERFLOW                   = $C0000091;
 
567
  STATUS_FLOAT_STACK_CHECK                = $C0000092;
 
568
  STATUS_FLOAT_UNDERFLOW                  = $C0000093;
 
569
  STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
 
570
  STATUS_INTEGER_OVERFLOW                 = $C0000095;
 
571
  STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
 
572
  STATUS_STACK_OVERFLOW                   = $C00000FD;
 
573
  STATUS_CONTROL_C_EXIT                   = $C000013A;
 
574
  STATUS_FLOAT_MULTIPLE_FAULTS    = $C00002B4;
 
575
  STATUS_FLOAT_MULTIPLE_TRAPS             = $C00002B5;
 
576
  STATUS_REG_NAT_CONSUMPTION              = $C00002C9;
 
577
 
 
578
  EXCEPTION_EXECUTE_HANDLER               = 1;
 
579
  EXCEPTION_CONTINUE_EXECUTION    = -1;
 
580
  EXCEPTION_CONTINUE_SEARCH               = 0;
 
581
 
 
582
  EXCEPTION_MAXIMUM_PARAMETERS    = 15;
 
583
 
 
584
  CONTEXT_X86                                     = $00010000;
 
585
  CONTEXT_CONTROL                         = CONTEXT_X86 or $00000001;
 
586
  CONTEXT_INTEGER                         = CONTEXT_X86 or $00000002;
 
587
  CONTEXT_SEGMENTS                        = CONTEXT_X86 or $00000004;
 
588
  CONTEXT_FLOATING_POINT          = CONTEXT_X86 or $00000008;
 
589
  CONTEXT_DEBUG_REGISTERS         = CONTEXT_X86 or $00000010;
 
590
  CONTEXT_EXTENDED_REGISTERS      = CONTEXT_X86 or $00000020;
 
591
 
 
592
  CONTEXT_FULL                            = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
 
593
 
 
594
  MAXIMUM_SUPPORTED_EXTENSION     = 512;
 
595
 
 
596
type
 
597
  PFloatingSaveArea = ^TFloatingSaveArea;
 
598
  TFloatingSaveArea = packed record
 
599
          ControlWord : Cardinal;
 
600
          StatusWord : Cardinal;
 
601
          TagWord : Cardinal;
 
602
          ErrorOffset : Cardinal;
 
603
          ErrorSelector : Cardinal;
 
604
          DataOffset : Cardinal;
 
605
          DataSelector : Cardinal;
 
606
          RegisterArea : array[0..79] of Byte;
 
607
          Cr0NpxState : Cardinal;
 
608
  end;
 
609
 
 
610
  PContext = ^TContext;
 
611
  TContext = packed record
 
612
      //
 
613
      // The flags values within this flag control the contents of
 
614
      // a CONTEXT record.
 
615
      //
 
616
          ContextFlags : Cardinal;
 
617
 
 
618
      //
 
619
      // This section is specified/returned if CONTEXT_DEBUG_REGISTERS is
 
620
      // set in ContextFlags.  Note that CONTEXT_DEBUG_REGISTERS is NOT
 
621
      // included in CONTEXT_FULL.
 
622
      //
 
623
          Dr0, Dr1, Dr2,
 
624
          Dr3, Dr6, Dr7 : Cardinal;
 
625
 
 
626
      //
 
627
      // This section is specified/returned if the
 
628
      // ContextFlags word contains the flag CONTEXT_FLOATING_POINT.
 
629
      //
 
630
          FloatSave : TFloatingSaveArea;
 
631
 
 
632
      //
 
633
      // This section is specified/returned if the
 
634
      // ContextFlags word contains the flag CONTEXT_SEGMENTS.
 
635
      //
 
636
          SegGs, SegFs,
 
637
          SegEs, SegDs : Cardinal;
 
638
 
 
639
      //
 
640
      // This section is specified/returned if the
 
641
      // ContextFlags word contains the flag CONTEXT_INTEGER.
 
642
      //
 
643
          Edi, Esi, Ebx,
 
644
          Edx, Ecx, Eax : Cardinal;
 
645
 
 
646
      //
 
647
      // This section is specified/returned if the
 
648
      // ContextFlags word contains the flag CONTEXT_CONTROL.
 
649
      //
 
650
          Ebp : Cardinal;
 
651
          Eip : Cardinal;
 
652
          SegCs : Cardinal;
 
653
          EFlags, Esp, SegSs : Cardinal;
 
654
 
 
655
      //
 
656
      // This section is specified/returned if the ContextFlags word
 
657
      // contains the flag CONTEXT_EXTENDED_REGISTERS.
 
658
      // The format and contexts are processor specific
 
659
      //
 
660
          ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte;
 
661
  end;
 
662
 
 
663
type
 
664
  PExceptionRecord = ^TExceptionRecord;
 
665
  TExceptionRecord = packed record
 
666
          ExceptionCode   : cardinal;
 
667
          ExceptionFlags  : Longint;
 
668
          ExceptionRecord : PExceptionRecord;
 
669
          ExceptionAddress : Pointer;
 
670
          NumberParameters : Longint;
 
671
          ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
 
672
  end;
 
673
 
 
674
  PExceptionPointers = ^TExceptionPointers;
 
675
  TExceptionPointers = packed record
 
676
          ExceptionRecord   : PExceptionRecord;
 
677
          ContextRecord     : PContext;
 
678
  end;
 
679
 
 
680
{ type of functions that should be used for exception handling }
 
681
  TTopLevelExceptionFilter = function (excep : PExceptionPointers) : Longint;stdcall;
 
682
 
 
683
function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : TTopLevelExceptionFilter) : TTopLevelExceptionFilter;
 
684
        stdcall;external 'kernel32' name 'SetUnhandledExceptionFilter';
 
685
 
 
686
const
 
687
  MaxExceptionLevel = 16;
 
688
  exceptLevel : Byte = 0;
 
689
 
 
690
var
 
691
  exceptEip       : array[0..MaxExceptionLevel-1] of Longint;
 
692
  exceptError     : array[0..MaxExceptionLevel-1] of Byte;
 
693
  resetFPU        : array[0..MaxExceptionLevel-1] of Boolean;
 
694
 
 
695
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
696
procedure DebugHandleErrorAddrFrame(error, addr, frame : longint);
 
697
begin
 
698
  if IsConsole then
 
699
    begin
 
700
      write(stderr,'HandleErrorAddrFrame(error=',error);
 
701
      write(stderr,',addr=',hexstr(addr,8));
 
702
      writeln(stderr,',frame=',hexstr(frame,8),')');
 
703
    end;
 
704
  HandleErrorAddrFrame(error,addr,frame);
 
705
end;
 
706
{$endif SYSTEMEXCEPTIONDEBUG}
 
707
 
 
708
procedure JumpToHandleErrorFrame;
 
709
  var
 
710
    eip, ebp, error : Longint;
 
711
  begin
 
712
    // save ebp
 
713
    asm
 
714
      movl (%ebp),%eax
 
715
      movl %eax,ebp
 
716
    end;
 
717
    if (exceptLevel > 0) then
 
718
      dec(exceptLevel);
 
719
 
 
720
    eip:=exceptEip[exceptLevel];
 
721
    error:=exceptError[exceptLevel];
 
722
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
723
    if IsConsole then
 
724
      writeln(stderr,'In JumpToHandleErrorFrame error=',error);
 
725
{$endif SYSTEMEXCEPTIONDEBUG}
 
726
    if resetFPU[exceptLevel] then
 
727
      SysResetFPU;
 
728
    { build a fake stack }
 
729
    asm
 
730
{$ifdef REGCALL}
 
731
      movl   ebp,%ecx
 
732
      movl   eip,%edx
 
733
      movl   error,%eax
 
734
      pushl  eip
 
735
      movl   ebp,%ebp // Change frame pointer
 
736
{$else}
 
737
      movl   ebp,%eax
 
738
      pushl  %eax
 
739
      movl   eip,%eax
 
740
      pushl  %eax
 
741
      movl   error,%eax
 
742
      pushl  %eax
 
743
      movl   eip,%eax
 
744
      pushl  %eax
 
745
      movl   ebp,%ebp // Change frame pointer
 
746
{$endif}
 
747
 
 
748
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
749
      jmpl   DebugHandleErrorAddrFrame
 
750
{$else not SYSTEMEXCEPTIONDEBUG}
 
751
      jmpl   HandleErrorAddrFrame
 
752
{$endif SYSTEMEXCEPTIONDEBUG}
 
753
    end;
 
754
  end;
 
755
 
 
756
function syswin32_i386_exception_handler(excep : PExceptionPointers) : Longint;stdcall;
 
757
  var
 
758
    res: longint;
 
759
    err: byte;
 
760
    must_reset_fpu: boolean;
 
761
  begin
 
762
    res := EXCEPTION_CONTINUE_SEARCH;
 
763
    if excep^.ContextRecord^.SegSs=_SS then begin
 
764
      err := 0;
 
765
      must_reset_fpu := true;
 
766
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
767
      if IsConsole then Writeln(stderr,'Exception  ',
 
768
              hexstr(excep^.ExceptionRecord^.ExceptionCode, 8));
 
769
{$endif SYSTEMEXCEPTIONDEBUG}
 
770
      case excep^.ExceptionRecord^.ExceptionCode of
 
771
        STATUS_INTEGER_DIVIDE_BY_ZERO,
 
772
        STATUS_FLOAT_DIVIDE_BY_ZERO :
 
773
          err := 200;
 
774
        STATUS_ARRAY_BOUNDS_EXCEEDED :
 
775
          begin
 
776
            err := 201;
 
777
            must_reset_fpu := false;
 
778
          end;
 
779
        STATUS_STACK_OVERFLOW :
 
780
          begin
 
781
            err := 202;
 
782
            must_reset_fpu := false;
 
783
          end;
 
784
        STATUS_FLOAT_OVERFLOW :
 
785
          err := 205;
 
786
        STATUS_FLOAT_DENORMAL_OPERAND,
 
787
        STATUS_FLOAT_UNDERFLOW :
 
788
          err := 206;
 
789
    {excep^.ContextRecord^.FloatSave.StatusWord := excep^.ContextRecord^.FloatSave.StatusWord and $ffffff00;}
 
790
        STATUS_FLOAT_INEXACT_RESULT,
 
791
        STATUS_FLOAT_INVALID_OPERATION,
 
792
        STATUS_FLOAT_STACK_CHECK :
 
793
          err := 207;
 
794
        STATUS_INTEGER_OVERFLOW :
 
795
          begin
 
796
            err := 215;
 
797
            must_reset_fpu := false;
 
798
          end;
 
799
        STATUS_ILLEGAL_INSTRUCTION:
 
800
          { if we're testing sse support, simply set the flag and continue }
 
801
          if sse_check then
 
802
            begin
 
803
              os_supports_sse:=false;
 
804
              { skip the offending movaps %xmm7, %xmm6 instruction }
 
805
              inc(excep^.ContextRecord^.Eip,3);
 
806
              excep^.ExceptionRecord^.ExceptionCode := 0;
 
807
              res:=EXCEPTION_CONTINUE_EXECUTION;
 
808
            end
 
809
          else
 
810
            err := 216;
 
811
        STATUS_ACCESS_VIOLATION:
 
812
          { Athlon prefetch bug? }
 
813
          if is_prefetch(pointer(excep^.ContextRecord^.Eip)) then
 
814
            begin
 
815
              { if yes, then retry }
 
816
              excep^.ExceptionRecord^.ExceptionCode := 0;
 
817
              res:=EXCEPTION_CONTINUE_EXECUTION;
 
818
            end
 
819
          else
 
820
            err := 216;
 
821
 
 
822
        STATUS_CONTROL_C_EXIT:
 
823
          err := 217;
 
824
        STATUS_PRIVILEGED_INSTRUCTION:
 
825
          begin
 
826
            err := 218;
 
827
            must_reset_fpu := false;
 
828
          end;
 
829
        else
 
830
          begin
 
831
            if ((excep^.ExceptionRecord^.ExceptionCode and SEVERITY_ERROR) = SEVERITY_ERROR) then
 
832
              err := 217
 
833
            else
 
834
              err := 255;
 
835
          end;
 
836
      end;
 
837
 
 
838
      if (err <> 0) and (exceptLevel < MaxExceptionLevel) then begin
 
839
        exceptEip[exceptLevel] := excep^.ContextRecord^.Eip;
 
840
        exceptError[exceptLevel] := err;
 
841
        resetFPU[exceptLevel] := must_reset_fpu;
 
842
        inc(exceptLevel);
 
843
 
 
844
        excep^.ContextRecord^.Eip := Longint(@JumpToHandleErrorFrame);
 
845
        excep^.ExceptionRecord^.ExceptionCode := 0;
 
846
 
 
847
        res := EXCEPTION_CONTINUE_EXECUTION;
 
848
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
849
        if IsConsole then begin
 
850
          writeln(stderr,'Exception Continue Exception set at ',
 
851
                  hexstr(exceptEip[exceptLevel],8));
 
852
          writeln(stderr,'Eip changed to ',
 
853
                  hexstr(longint(@JumpToHandleErrorFrame),8), ' error=', error);
 
854
        end;
 
855
{$endif SYSTEMEXCEPTIONDEBUG}
 
856
      end;
 
857
    end;
 
858
    syswin32_i386_exception_handler := res;
 
859
  end;
 
860
 
 
861
procedure install_exception_handlers;
 
862
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
863
  var
 
864
    oldexceptaddr,
 
865
    newexceptaddr : Longint;
 
866
{$endif SYSTEMEXCEPTIONDEBUG}
 
867
 
 
868
  begin
 
869
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
870
    asm
 
871
      movl $0,%eax
 
872
      movl %fs:(%eax),%eax
 
873
      movl %eax,oldexceptaddr
 
874
    end;
 
875
{$endif SYSTEMEXCEPTIONDEBUG}
 
876
    SetUnhandledExceptionFilter(@syswin32_i386_exception_handler);
 
877
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
878
    asm
 
879
      movl $0,%eax
 
880
      movl %fs:(%eax),%eax
 
881
      movl %eax,newexceptaddr
 
882
    end;
 
883
    if IsConsole then
 
884
      writeln(stderr,'Old exception  ',hexstr(oldexceptaddr,8),
 
885
                     ' new exception  ',hexstr(newexceptaddr,8));
 
886
{$endif SYSTEMEXCEPTIONDEBUG}
 
887
  end;
 
888
 
 
889
procedure remove_exception_handlers;
 
890
  begin
 
891
    SetUnhandledExceptionFilter(nil);
 
892
  end;
 
893
 
 
894
{$else not cpui386 (Processor specific !!)}
 
895
procedure install_exception_handlers;
 
896
begin
 
897
end;
 
898
 
 
899
procedure remove_exception_handlers;
 
900
begin
 
901
end;
 
902
 
 
903
{$endif Set_i386_Exception_handler}
 
904
 
 
905
{****************************************************************************
 
906
                      OS dependend widestrings
 
907
****************************************************************************}
 
908
 
 
909
const
 
910
  { MultiByteToWideChar  }
 
911
     MB_PRECOMPOSED = 1;
 
912
     CP_ACP = 0;
 
913
 
 
914
function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
 
915
    stdcall; external 'kernel32' name 'MultiByteToWideChar';
 
916
function WideCharToMultiByte(CodePage:UINT; dwFlags:DWORD; lpWideCharStr:PWideChar; cchWideChar:longint; lpMultiByteStr:PChar;cchMultiByte:longint; lpDefaultChar:PChar; lpUsedDefaultChar:pointer):longint;
 
917
    stdcall; external 'kernel32' name 'WideCharToMultiByte';
 
918
function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
 
919
    stdcall; external 'user32' name 'CharUpperBuffW';
 
920
function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
 
921
    stdcall; external 'user32' name 'CharLowerBuffW';
 
922
 
 
923
 
 
924
procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
 
925
  var
 
926
    destlen: SizeInt;
 
927
  begin
 
928
    // retrieve length including trailing #0
 
929
    destlen:=WideCharToMultiByte(CP_ACP, 0, source, len+1, nil, 0, nil, nil);
 
930
    setlength(dest, destlen-1);
 
931
    WideCharToMultiByte(CP_ACP, 0, source, len+1, @dest[1], destlen, nil, nil);
 
932
  end;
 
933
 
 
934
procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
 
935
  var
 
936
    destlen: SizeInt;
 
937
  begin
 
938
    // retrieve length including trailing #0
 
939
    destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, nil, 0);
 
940
    setlength(dest, destlen-1);
 
941
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, @dest[1], destlen);
 
942
  end;
 
943
 
 
944
 
 
945
function Win32WideUpper(const s : WideString) : WideString;
 
946
  begin
 
947
    result:=s;
 
948
    UniqueString(result);
 
949
    if length(result)>0 then
 
950
      CharUpperBuff(LPWSTR(result),length(result));
 
951
  end;
 
952
 
 
953
 
 
954
function Win32WideLower(const s : WideString) : WideString;
 
955
  begin
 
956
    result:=s;
 
957
    UniqueString(result);
 
958
    if length(result)>0 then
 
959
      CharLowerBuff(LPWSTR(result),length(result));
 
960
  end;
 
961
 
 
962
 
 
963
{ there is a similiar procedure in sysutils which inits the fields which
 
964
  are only relevant for the sysutils units }
 
965
procedure InitWin32Widestrings;
 
966
  begin
 
967
    widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
 
968
    widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
 
969
    widestringmanager.UpperWideStringProc:=@Win32WideUpper;
 
970
    widestringmanager.LowerWideStringProc:=@Win32WideLower;
 
971
  end;
 
972
 
 
973
 
 
974
 
 
975
{****************************************************************************
 
976
                    Error Message writing using messageboxes
 
977
****************************************************************************}
 
978
 
 
979
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
 
980
   stdcall;external 'user32' name 'MessageBoxA';
 
981
 
 
982
const
 
983
  ErrorBufferLength = 1024;
 
984
var
 
985
  ErrorBuf : array[0..ErrorBufferLength] of char;
 
986
  ErrorLen : longint;
 
987
 
 
988
Function ErrorWrite(Var F: TextRec): Integer;
 
989
{
 
990
  An error message should always end with #13#10#13#10
 
991
}
 
992
var
 
993
  p : pchar;
 
994
  i : longint;
 
995
Begin
 
996
  if F.BufPos>0 then
 
997
   begin
 
998
     if F.BufPos+ErrorLen>ErrorBufferLength then
 
999
       i:=ErrorBufferLength-ErrorLen
 
1000
     else
 
1001
       i:=F.BufPos;
 
1002
     Move(F.BufPtr^,ErrorBuf[ErrorLen],i);
 
1003
     inc(ErrorLen,i);
 
1004
     ErrorBuf[ErrorLen]:=#0;
 
1005
   end;
 
1006
  if ErrorLen>3 then
 
1007
   begin
 
1008
     p:=@ErrorBuf[ErrorLen];
 
1009
     for i:=1 to 4 do
 
1010
      begin
 
1011
        dec(p);
 
1012
        if not(p^ in [#10,#13]) then
 
1013
         break;
 
1014
      end;
 
1015
   end;
 
1016
   if ErrorLen=ErrorBufferLength then
 
1017
     i:=4;
 
1018
   if (i=4) then
 
1019
    begin
 
1020
      MessageBox(0,@ErrorBuf,pchar('Error'),0);
 
1021
      ErrorLen:=0;
 
1022
    end;
 
1023
  F.BufPos:=0;
 
1024
  ErrorWrite:=0;
 
1025
End;
 
1026
 
 
1027
 
 
1028
Function ErrorClose(Var F: TextRec): Integer;
 
1029
begin
 
1030
  if ErrorLen>0 then
 
1031
   begin
 
1032
     MessageBox(0,@ErrorBuf,pchar('Error'),0);
 
1033
     ErrorLen:=0;
 
1034
   end;
 
1035
  ErrorLen:=0;
 
1036
  ErrorClose:=0;
 
1037
end;
 
1038
 
 
1039
 
 
1040
Function ErrorOpen(Var F: TextRec): Integer;
 
1041
Begin
 
1042
  TextRec(F).InOutFunc:=@ErrorWrite;
 
1043
  TextRec(F).FlushFunc:=@ErrorWrite;
 
1044
  TextRec(F).CloseFunc:=@ErrorClose;
 
1045
  ErrorOpen:=0;
 
1046
End;
 
1047
 
 
1048
 
 
1049
procedure AssignError(Var T: Text);
 
1050
begin
 
1051
  Assign(T,'');
 
1052
  TextRec(T).OpenFunc:=@ErrorOpen;
 
1053
  Rewrite(T);
 
1054
end;
 
1055
 
 
1056
 
 
1057
procedure SysInitStdIO;
 
1058
begin
 
1059
  { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
 
1060
    displayed in a messagebox }
 
1061
  StdInputHandle:=longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
 
1062
  StdOutputHandle:=longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
 
1063
  StdErrorHandle:=longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
 
1064
  if not IsConsole then
 
1065
   begin
 
1066
     AssignError(stderr);
 
1067
     AssignError(stdout);
 
1068
     Assign(Output,'');
 
1069
     Assign(Input,'');
 
1070
     Assign(ErrOutput,'');
 
1071
   end
 
1072
  else
 
1073
   begin
 
1074
     OpenStdIO(Input,fmInput,StdInputHandle);
 
1075
     OpenStdIO(Output,fmOutput,StdOutputHandle);
 
1076
     OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
 
1077
     OpenStdIO(StdOut,fmOutput,StdOutputHandle);
 
1078
     OpenStdIO(StdErr,fmOutput,StdErrorHandle);
 
1079
   end;
 
1080
end;
 
1081
 
 
1082
(* ProcessID cached to avoid repeated calls to GetCurrentProcess. *)
 
1083
 
 
1084
var
 
1085
  ProcessID: SizeUInt;
 
1086
 
 
1087
function GetProcessID: SizeUInt;
 
1088
begin
 
1089
 GetProcessID := ProcessID;
 
1090
end;
 
1091
 
 
1092
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
 
1093
begin
 
1094
  result := stklen;
 
1095
end;
 
1096
 
 
1097
{
 
1098
const
 
1099
   Exe_entry_code : pointer = @Exe_entry;
 
1100
   Dll_entry_code : pointer = @Dll_entry;
 
1101
}
 
1102
 
 
1103
begin
 
1104
  StackLength := CheckInitialStkLen(InitialStkLen);
 
1105
  StackBottom := StackTop - StackLength;
 
1106
  { get some helpful informations }
 
1107
  GetStartupInfo(@startupinfo);
 
1108
  { some misc Win32 stuff }
 
1109
  hprevinst:=0;
 
1110
  if not IsLibrary then
 
1111
    SysInstance:=getmodulehandle(GetCommandFile);
 
1112
  MainInstance:=HInstance;
 
1113
  cmdshow:=startupinfo.wshowwindow;
 
1114
  { Setup heap }
 
1115
  InitHeap;
 
1116
  SysInitExceptions;
 
1117
  { setup fastmove stuff }
 
1118
  fpc_cpucodeinit;
 
1119
  SysInitStdIO;
 
1120
  { Arguments }
 
1121
  setup_arguments;
 
1122
  { Reset IO Error }
 
1123
  InOutRes:=0;
 
1124
  ProcessID := GetCurrentProcessID;
 
1125
  { threading }
 
1126
  InitSystemThreads;
 
1127
  { Reset internal error variable }
 
1128
  errno:=0;
 
1129
  initvariantmanager;
 
1130
  initwidestringmanager;
 
1131
  InitWin32Widestrings;
 
1132
  DispCallByIDProc:=@DoDispCallByIDError;
 
1133
end.