← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/win32/syswin32.pp

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2001-08-29 23:15:17 UTC
  • Revision ID: james.westby@ubuntu.com-20010829231517-thxsp7ctuab584ia
Tags: upstream-1.0.4
Import upstream version 1.0.4

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/win32/syswin32.pp
 
1
{
 
2
    $Id: syswin32.pp,v 1.1.2.1 2000/10/02 22:15:39 pierre Exp $
 
3
    This file is part of the Free Pascal run time library.
 
4
    Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
 
5
    member of the Free Pascal development team.
 
6
 
 
7
    FPC Pascal system unit for the Win32 API.
 
8
 
 
9
    See the file COPYING.FPC, included in this distribution,
 
10
    for details about the copyright.
 
11
 
 
12
    This program is distributed in the hope that it will be useful,
 
13
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
15
 
 
16
 **********************************************************************}
 
17
unit syswin32;
 
18
interface
 
19
 
 
20
{$ifdef SYSTEMDEBUG}
 
21
  {$define SYSTEMEXCEPTIONDEBUG}
 
22
{$endif SYSTEMDEBUG}
 
23
 
 
24
{$ifdef i386}
 
25
  {$define Set_i386_Exception_handler}
 
26
{$endif i386}
 
27
 
 
28
{ include system-independent routine headers }
 
29
{$I systemh.inc}
 
30
 
 
31
{ include heap support headers }
 
32
{$I heaph.inc}
 
33
 
 
34
const
 
35
{ Default filehandles }
 
36
   UnusedHandle    : longint = -1;
 
37
   StdInputHandle  : longint = 0;
 
38
   StdOutputHandle : longint = 0;
 
39
   StdErrorHandle  : longint = 0;
 
40
 
 
41
   FileNameCaseSensitive : boolean = true;
 
42
 
 
43
type
 
44
  TStartupInfo=packed record
 
45
    cb : longint;
 
46
    lpReserved : Pointer;
 
47
    lpDesktop : Pointer;
 
48
    lpTitle : Pointer;
 
49
    dwX : longint;
 
50
    dwY : longint;
 
51
    dwXSize : longint;
 
52
    dwYSize : longint;
 
53
    dwXCountChars : longint;
 
54
    dwYCountChars : longint;
 
55
    dwFillAttribute : longint;
 
56
    dwFlags : longint;
 
57
    wShowWindow : Word;
 
58
    cbReserved2 : Word;
 
59
    lpReserved2 : Pointer;
 
60
    hStdInput : longint;
 
61
    hStdOutput : longint;
 
62
    hStdError : longint;
 
63
  end;
 
64
 
 
65
var
 
66
{ C compatible arguments }
 
67
  argc  : longint;
 
68
  argv  : ppchar;
 
69
{ Win32 Info }
 
70
  startupinfo : tstartupinfo;
 
71
  hprevinst,
 
72
  HInstance,
 
73
  MainInstance,
 
74
  cmdshow     : longint;
 
75
  DLLreason,DLLparam:longint;
 
76
  Win32StackTop : Dword;
 
77
{ Thread count for DLL }
 
78
const
 
79
  Thread_count : longint = 0;
 
80
type
 
81
  TDLL_Process_Entry_Hook = function (dllparam : longint) : longbool;
 
82
  TDLL_Entry_Hook = procedure (dllparam : longint);
 
83
 
 
84
const
 
85
  Dll_Process_Attach_Hook : TDLL_Process_Entry_Hook = nil;
 
86
  Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
 
87
  Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
 
88
  Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
 
89
 
 
90
implementation
 
91
 
 
92
{ include system independent routines }
 
93
{$I system.inc}
 
94
 
 
95
{ some declarations for Win32 API calls }
 
96
{$I win32.inc}
 
97
 
 
98
 
 
99
CONST
 
100
  { These constants are used for conversion of error codes }
 
101
  { from win32 i/o errors to tp i/o errors                 }
 
102
  { errors 1 to 18 are the same as in Turbo Pascal         }
 
103
  { DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING! }
 
104
 
 
105
{  The media is write protected.                   }
 
106
    ERROR_WRITE_PROTECT       =      19;
 
107
{  The system cannot find the device specified.    }
 
108
    ERROR_BAD_UNIT            =      20;
 
109
{  The device is not ready.                        }
 
110
    ERROR_NOT_READY           =      21;
 
111
{  The device does not recognize the command.      }
 
112
    ERROR_BAD_COMMAND         =      22;
 
113
{  Data error (cyclic redundancy check)            }
 
114
    ERROR_CRC                 =      23;
 
115
{  The program issued a command but the            }
 
116
{  command length is incorrect.                    }
 
117
    ERROR_BAD_LENGTH           =     24;
 
118
{  The drive cannot locate a specific              }
 
119
{  area or track on the disk.                      }
 
120
    ERROR_SEEK                 =     25;
 
121
{  The specified disk or diskette cannot be accessed. }
 
122
    ERROR_NOT_DOS_DISK         =     26;
 
123
{  The drive cannot find the sector requested.     }
 
124
    ERROR_SECTOR_NOT_FOUND      =    27;
 
125
{  The printer is out of paper.                    }
 
126
    ERROR_OUT_OF_PAPER          =    28;
 
127
{  The system cannot write to the specified device. }
 
128
    ERROR_WRITE_FAULT           =    29;
 
129
{  The system cannot read from the specified device. }
 
130
    ERROR_READ_FAULT            =    30;
 
131
{  A device attached to the system is not functioning.}
 
132
    ERROR_GEN_FAILURE           =    31;
 
133
{  The process cannot access the file because         }
 
134
{  it is being used by another process.               }
 
135
    ERROR_SHARING_VIOLATION      =   32;
 
136
 
 
137
var
 
138
    errno : longint;
 
139
 
 
140
{$ASMMODE ATT}
 
141
 
 
142
 
 
143
   { misc. functions }
 
144
   function GetLastError : DWORD;
 
145
     external 'kernel32' name 'GetLastError';
 
146
 
 
147
   { time and date functions }
 
148
   function GetTickCount : longint;
 
149
     external 'kernel32' name 'GetTickCount';
 
150
 
 
151
   { process functions }
 
152
   procedure ExitProcess(uExitCode : UINT);
 
153
     external 'kernel32' name 'ExitProcess';
 
154
 
 
155
 
 
156
   Procedure Errno2InOutRes;
 
157
   Begin
 
158
     { DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
 
159
     if (errno >= ERROR_WRITE_PROTECT) and (errno <= ERROR_GEN_FAILURE) THEN
 
160
       BEGIN
 
161
          { This is the offset to the Win32 to add to directly map  }
 
162
          { to the DOS/TP compatible error codes when in this range }
 
163
          InOutRes := word(errno)+131;
 
164
       END
 
165
     else
 
166
     { This case is special }
 
167
     if errno=ERROR_SHARING_VIOLATION THEN
 
168
       BEGIN
 
169
         InOutRes :=5;
 
170
       END
 
171
     else
 
172
     { other error codes can directly be mapped }
 
173
         InOutRes := Word(errno);
 
174
     errno:=0;
 
175
   end;
 
176
 
 
177
 
 
178
{$ifdef dummy}
 
179
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
 
180
{
 
181
  called when trying to get local stack if the compiler directive $S
 
182
  is set this function must preserve esi !!!! because esi is set by
 
183
  the calling proc for methods it must preserve all registers !!
 
184
 
 
185
  With a 2048 byte safe area used to write to StdIo without crossing
 
186
  the stack boundary
 
187
 
 
188
}
 
189
begin
 
190
  asm
 
191
        pushl   %eax
 
192
        pushl   %ebx
 
193
        movl    stack_size,%ebx
 
194
        addl    $2048,%ebx
 
195
        movl    %esp,%eax
 
196
        subl    %ebx,%eax
 
197
        movl    stacklimit,%ebx
 
198
        cmpl    %eax,%ebx
 
199
        jae     .L__short_on_stack
 
200
        popl    %ebx
 
201
        popl    %eax
 
202
        leave
 
203
        ret     $4
 
204
.L__short_on_stack:
 
205
        { can be usefull for error recovery !! }
 
206
        popl    %ebx
 
207
        popl    %eax
 
208
  end['EAX','EBX'];
 
209
  HandleError(202);
 
210
end;
 
211
{$endif dummy}
 
212
 
 
213
 
 
214
function paramcount : longint;
 
215
begin
 
216
  paramcount := argc - 1;
 
217
end;
 
218
 
 
219
   { module functions }
 
220
   function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
 
221
     external 'kernel32' name 'GetModuleFileNameA';
 
222
   function GetModuleHandle(p : pointer) : longint;
 
223
     external 'kernel32' name 'GetModuleHandleA';
 
224
   function GetCommandFile:pchar;forward;
 
225
 
 
226
function paramstr(l : longint) : string;
 
227
begin
 
228
  if (l>=0) and (l<argc) then
 
229
    paramstr:=strpas(argv[l])
 
230
  else
 
231
    paramstr:='';
 
232
end;
 
233
 
 
234
 
 
235
procedure randomize;
 
236
begin
 
237
  randseed:=GetTickCount;
 
238
end;
 
239
 
 
240
 
 
241
{*****************************************************************************
 
242
                              Heap Management
 
243
*****************************************************************************}
 
244
 
 
245
   { memory functions }
 
246
   function GlobalAlloc(mode,size:longint):longint;
 
247
     external 'kernel32' name 'GlobalAlloc';
 
248
   function GlobalLock(handle:longint):pointer;
 
249
     external 'kernel32' name 'GlobalLock';
 
250
{$ifdef SYSTEMDEBUG}
 
251
   function GlobalSize(h:longint):longint;
 
252
     external 'kernel32' name 'GlobalSize';
 
253
{$endif}
 
254
 
 
255
var
 
256
  heap : longint;external name 'HEAP';
 
257
  intern_heapsize : longint;external name 'HEAPSIZE';
 
258
 
 
259
function getheapstart:pointer;assembler;
 
260
asm
 
261
        leal    HEAP,%eax
 
262
end ['EAX'];
 
263
 
 
264
 
 
265
function getheapsize:longint;assembler;
 
266
asm
 
267
        movl    intern_HEAPSIZE,%eax
 
268
end ['EAX'];
 
269
 
 
270
 
 
271
function Sbrk(size : longint):longint;
 
272
var
 
273
  h,l : longint;
 
274
begin
 
275
  h:=GlobalAlloc(258,size);
 
276
  l:=longint(GlobalLock(h));
 
277
  if l=0 then
 
278
    l:=-1;
 
279
{$ifdef DUMPGROW}
 
280
  Writeln('new heap part at $',hexstr(l,8), ' size = ',GlobalSize(h));
 
281
{$endif}
 
282
  sbrk:=l;
 
283
end;
 
284
 
 
285
{ include standard heap management }
 
286
{$I heap.inc}
 
287
 
 
288
 
 
289
{*****************************************************************************
 
290
                          Low Level File Routines
 
291
*****************************************************************************}
 
292
 
 
293
   function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
 
294
     overlap:pointer):longint;
 
295
     external 'kernel32' name 'WriteFile';
 
296
   function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
 
297
     overlap:pointer):longint;
 
298
     external 'kernel32' name 'ReadFile';
 
299
   function CloseHandle(h : longint) : longint;
 
300
     external 'kernel32' name 'CloseHandle';
 
301
   function DeleteFile(p : pchar) : longint;
 
302
     external 'kernel32' name 'DeleteFileA';
 
303
   function MoveFile(old,_new : pchar) : longint;
 
304
     external 'kernel32' name 'MoveFileA';
 
305
   function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint;
 
306
     external 'kernel32' name 'SetFilePointer';
 
307
   function GetFileSize(h:longint;p:pointer) : longint;
 
308
     external 'kernel32' name 'GetFileSize';
 
309
   function CreateFile(name : pointer;access,sharing : longint;
 
310
     security : pointer;how,attr,template : longint) : longint;
 
311
     external 'kernel32' name 'CreateFileA';
 
312
   function SetEndOfFile(h : longint) : longbool;
 
313
     external 'kernel32' name 'SetEndOfFile';
 
314
   function GetFileType(Handle:DWORD):DWord;
 
315
     external 'kernel32' name 'GetFileType';
 
316
 
 
317
 
 
318
procedure AllowSlash(p:pchar);
 
319
var
 
320
   i : longint;
 
321
begin
 
322
{ allow slash as backslash }
 
323
   for i:=0 to strlen(p) do
 
324
     if p[i]='/' then p[i]:='\';
 
325
end;
 
326
 
 
327
function do_isdevice(handle:longint):boolean;
 
328
begin
 
329
  do_isdevice:=(getfiletype(handle)=2);
 
330
end;
 
331
 
 
332
 
 
333
procedure do_close(h : longint);
 
334
begin
 
335
  if do_isdevice(h) then
 
336
   exit;
 
337
  CloseHandle(h);
 
338
end;
 
339
 
 
340
 
 
341
procedure do_erase(p : pchar);
 
342
begin
 
343
   AllowSlash(p);
 
344
   if DeleteFile(p)=0 then
 
345
    Begin
 
346
      errno:=GetLastError;
 
347
      Errno2InoutRes;
 
348
    end;
 
349
end;
 
350
 
 
351
 
 
352
procedure do_rename(p1,p2 : pchar);
 
353
begin
 
354
  AllowSlash(p1);
 
355
  AllowSlash(p2);
 
356
  if MoveFile(p1,p2)=0 then
 
357
   Begin
 
358
      errno:=GetLastError;
 
359
      Errno2InoutRes;
 
360
   end;
 
361
end;
 
362
 
 
363
 
 
364
function do_write(h,addr,len : longint) : longint;
 
365
var
 
366
   size:longint;
 
367
begin
 
368
   if writefile(h,pointer(addr),len,size,nil)=0 then
 
369
    Begin
 
370
      errno:=GetLastError;
 
371
      Errno2InoutRes;
 
372
    end;
 
373
   do_write:=size;
 
374
end;
 
375
 
 
376
 
 
377
function do_read(h,addr,len : longint) : longint;
 
378
var
 
379
  _result:longint;
 
380
begin
 
381
  if readfile(h,pointer(addr),len,_result,nil)=0 then
 
382
    Begin
 
383
      errno:=GetLastError;
 
384
      Errno2InoutRes;
 
385
    end;
 
386
  do_read:=_result;
 
387
end;
 
388
 
 
389
 
 
390
function do_filepos(handle : longint) : longint;
 
391
var
 
392
  l:longint;
 
393
begin
 
394
  l:=SetFilePointer(handle,0,nil,FILE_CURRENT);
 
395
  if l=-1 then
 
396
   begin
 
397
    l:=0;
 
398
    errno:=GetLastError;
 
399
    Errno2InoutRes;
 
400
   end;
 
401
  do_filepos:=l;
 
402
end;
 
403
 
 
404
 
 
405
procedure do_seek(handle,pos : longint);
 
406
begin
 
407
  if SetFilePointer(handle,pos,nil,FILE_BEGIN)=-1 then
 
408
   Begin
 
409
    errno:=GetLastError;
 
410
    Errno2InoutRes;
 
411
   end;
 
412
end;
 
413
 
 
414
 
 
415
function do_seekend(handle:longint):longint;
 
416
begin
 
417
  do_seekend:=SetFilePointer(handle,0,nil,FILE_END);
 
418
  if do_seekend=-1 then
 
419
    begin
 
420
      errno:=GetLastError;
 
421
      Errno2InoutRes;
 
422
    end;
 
423
end;
 
424
 
 
425
 
 
426
function do_filesize(handle : longint) : longint;
 
427
var
 
428
  aktfilepos : longint;
 
429
begin
 
430
  aktfilepos:=do_filepos(handle);
 
431
  do_filesize:=do_seekend(handle);
 
432
  do_seek(handle,aktfilepos);
 
433
end;
 
434
 
 
435
 
 
436
procedure do_truncate (handle,pos:longint);
 
437
begin
 
438
   do_seek(handle,pos);
 
439
   if not(SetEndOfFile(handle)) then
 
440
    begin
 
441
      errno:=GetLastError;
 
442
      Errno2InoutRes;
 
443
    end;
 
444
end;
 
445
 
 
446
 
 
447
procedure do_open(var f;p : pchar;flags:longint);
 
448
{
 
449
  filerec and textrec have both handle and mode as the first items so
 
450
  they could use the same routine for opening/creating.
 
451
  when (flags and $100)   the file will be append
 
452
  when (flags and $1000)  the file will be truncate/rewritten
 
453
  when (flags and $10000) there is no check for close (needed for textfiles)
 
454
}
 
455
Const
 
456
  file_Share_Read  = $00000001;
 
457
  file_Share_Write = $00000002;
 
458
Var
 
459
  shflags,
 
460
  oflags,cd : longint;
 
461
begin
 
462
  AllowSlash(p);
 
463
{ close first if opened }
 
464
  if ((flags and $10000)=0) then
 
465
   begin
 
466
     case filerec(f).mode of
 
467
       fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
 
468
       fmclosed : ;
 
469
     else
 
470
      begin
 
471
        {not assigned}
 
472
        inoutres:=102;
 
473
        exit;
 
474
      end;
 
475
     end;
 
476
   end;
 
477
{ reset file handle }
 
478
  filerec(f).handle:=UnusedHandle;
 
479
{ convert filesharing }
 
480
  shflags:=0;
 
481
  if ((filemode and fmshareExclusive) = fmshareExclusive) then
 
482
    { no sharing }
 
483
  else
 
484
    if (filemode = fmShareCompat) or ((filemode and fmshareDenyWrite) = fmshareDenyWrite) then
 
485
      shflags := file_Share_Read
 
486
  else
 
487
    if ((filemode and fmshareDenyRead) = fmshareDenyRead) then
 
488
      shflags := file_Share_Write
 
489
  else
 
490
    if ((filemode and fmshareDenyNone) = fmshareDenyNone) then
 
491
      shflags := file_Share_Read + file_Share_Write;
 
492
{ convert filemode to filerec modes }
 
493
  case (flags and 3) of
 
494
   0 : begin
 
495
         filerec(f).mode:=fminput;
 
496
         oflags:=GENERIC_READ;
 
497
       end;
 
498
   1 : begin
 
499
         filerec(f).mode:=fmoutput;
 
500
         oflags:=GENERIC_WRITE;
 
501
       end;
 
502
   2 : begin
 
503
         filerec(f).mode:=fminout;
 
504
         oflags:=GENERIC_WRITE or GENERIC_READ;
 
505
       end;
 
506
  end;
 
507
{ standard is opening and existing file }
 
508
  cd:=OPEN_EXISTING;
 
509
{ create it ? }
 
510
  if (flags and $1000)<>0 then
 
511
   cd:=CREATE_ALWAYS
 
512
{ or append ? }
 
513
  else
 
514
   if (flags and $100)<>0 then
 
515
    cd:=OPEN_ALWAYS;
 
516
{ empty name is special }
 
517
  if p[0]=#0 then
 
518
   begin
 
519
     case FileRec(f).mode of
 
520
       fminput :
 
521
         FileRec(f).Handle:=StdInputHandle;
 
522
       fminout, { this is set by rewrite }
 
523
       fmoutput :
 
524
         FileRec(f).Handle:=StdOutputHandle;
 
525
       fmappend :
 
526
         begin
 
527
           FileRec(f).Handle:=StdOutputHandle;
 
528
           FileRec(f).mode:=fmoutput; {fool fmappend}
 
529
         end;
 
530
     end;
 
531
     exit;
 
532
   end;
 
533
  filerec(f).handle:=CreateFile(p,oflags,shflags,nil,cd,FILE_ATTRIBUTE_NORMAL,0);
 
534
{ append mode }
 
535
  if (flags and $100)<>0 then
 
536
   begin
 
537
     do_seekend(filerec(f).handle);
 
538
     filerec(f).mode:=fmoutput; {fool fmappend}
 
539
   end;
 
540
{ get errors }
 
541
  { handle -1 is returned sometimes !! (PM) }
 
542
  if (filerec(f).handle=0) or (filerec(f).handle=-1) then
 
543
    begin
 
544
      errno:=GetLastError;
 
545
      Errno2InoutRes;
 
546
    end;
 
547
end;
 
548
 
 
549
 
 
550
 
 
551
 
 
552
{*****************************************************************************
 
553
                           UnTyped File Handling
 
554
*****************************************************************************}
 
555
 
 
556
{$i file.inc}
 
557
 
 
558
{*****************************************************************************
 
559
                           Typed File Handling
 
560
*****************************************************************************}
 
561
 
 
562
{$i typefile.inc}
 
563
 
 
564
{*****************************************************************************
 
565
                           Text File Handling
 
566
*****************************************************************************}
 
567
 
 
568
{$DEFINE EOF_CTRLZ}
 
569
 
 
570
{$i text.inc}
 
571
 
 
572
{*****************************************************************************
 
573
                           Directory Handling
 
574
*****************************************************************************}
 
575
 
 
576
   function CreateDirectory(name : pointer;sec : pointer) : longint;
 
577
     external 'kernel32' name 'CreateDirectoryA';
 
578
   function RemoveDirectory(name:pointer):longint;
 
579
     external 'kernel32' name 'RemoveDirectoryA';
 
580
   function SetCurrentDirectory(name : pointer) : longint;
 
581
     external 'kernel32' name 'SetCurrentDirectoryA';
 
582
   function GetCurrentDirectory(bufsize : longint;name : pchar) : longint;
 
583
     external 'kernel32' name 'GetCurrentDirectoryA';
 
584
 
 
585
type
 
586
 TDirFnType=function(name:pointer):word;
 
587
 
 
588
procedure dirfn(afunc : TDirFnType;const s:string);
 
589
var
 
590
  buffer : array[0..255] of char;
 
591
begin
 
592
  move(s[1],buffer,length(s));
 
593
  buffer[length(s)]:=#0;
 
594
  AllowSlash(pchar(@buffer));
 
595
  if aFunc(@buffer)=0 then
 
596
    begin
 
597
      errno:=GetLastError;
 
598
      Errno2InoutRes;
 
599
    end;
 
600
end;
 
601
 
 
602
function CreateDirectoryTrunc(name:pointer):word;
 
603
 begin
 
604
  CreateDirectoryTrunc:=CreateDirectory(name,nil);
 
605
 end;
 
606
 
 
607
procedure mkdir(const s:string);[IOCHECK];
 
608
 begin
 
609
  If InOutRes <> 0 then exit;
 
610
  dirfn(TDirFnType(@CreateDirectoryTrunc),s);
 
611
 end;
 
612
 
 
613
procedure rmdir(const s:string);[IOCHECK];
 
614
 begin
 
615
  If InOutRes <> 0 then exit;
 
616
  dirfn(TDirFnType(@RemoveDirectory),s);
 
617
 end;
 
618
 
 
619
procedure chdir(const s:string);[IOCHECK];
 
620
 begin
 
621
  If InOutRes <> 0 then exit;
 
622
  dirfn(TDirFnType(@SetCurrentDirectory),s);
 
623
 end;
 
624
 
 
625
procedure getdir(drivenr:byte;var dir:shortstring);
 
626
const
 
627
  Drive:array[0..3]of char=(#0,':',#0,#0);
 
628
var
 
629
  defaultdrive:boolean;
 
630
  DirBuf,SaveBuf:array[0..259] of Char;
 
631
begin
 
632
  defaultdrive:=drivenr=0;
 
633
  if not defaultdrive then
 
634
   begin
 
635
    byte(Drive[0]):=Drivenr+64;
 
636
    GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
 
637
    SetCurrentDirectory(@Drive);
 
638
   end;
 
639
  GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
 
640
  if not defaultdrive then
 
641
   SetCurrentDirectory(@SaveBuf);
 
642
  dir:=strpas(DirBuf);
 
643
  if not FileNameCaseSensitive then
 
644
   dir:=upcase(dir);
 
645
end;
 
646
 
 
647
 
 
648
{*****************************************************************************
 
649
                         SystemUnit Initialization
 
650
*****************************************************************************}
 
651
 
 
652
   { Startup }
 
653
   procedure GetStartupInfo(p : pointer);
 
654
     external 'kernel32' name 'GetStartupInfoA';
 
655
   function GetStdHandle(nStdHandle:DWORD):THANDLE;
 
656
     external 'kernel32' name 'GetStdHandle';
 
657
 
 
658
   { command line/enviroment functions }
 
659
   function GetCommandLine : pchar;
 
660
     external 'kernel32' name 'GetCommandLineA';
 
661
 
 
662
 
 
663
var
 
664
  ModuleName : array[0..255] of char;
 
665
 
 
666
function GetCommandFile:pchar;
 
667
begin
 
668
  GetModuleFileName(0,@ModuleName,255);
 
669
  GetCommandFile:=@ModuleName;
 
670
end;
 
671
 
 
672
 
 
673
procedure setup_arguments;
 
674
var
 
675
  arglen,
 
676
  count   : longint;
 
677
  argstart,
 
678
  pc      : pchar;
 
679
  quote   : set of char;
 
680
  argsbuf : array[0..127] of pchar;
 
681
begin
 
682
  { create commandline, it starts with the executed filename which is argv[0] }
 
683
  { Win32 passes the command NOT via the args, but via getmodulefilename}
 
684
  count:=0;
 
685
  pc:=getcommandfile;
 
686
  Arglen:=0;
 
687
  repeat
 
688
    Inc(Arglen);
 
689
  until (pc[Arglen]=#0);
 
690
  getmem(argsbuf[count],arglen+1);
 
691
  move(pc^,argsbuf[count]^,arglen);
 
692
  { Now skip the first one }
 
693
  pc:=GetCommandLine;
 
694
  repeat
 
695
    { skip leading spaces }
 
696
    while pc^ in [' ',#9,#13] do
 
697
     inc(pc);
 
698
    case pc^ of
 
699
      #0 : break;
 
700
     '"' : begin
 
701
             quote:=['"'];
 
702
             inc(pc);
 
703
           end;
 
704
    '''' : begin
 
705
             quote:=[''''];
 
706
             inc(pc);
 
707
           end;
 
708
    else
 
709
     quote:=[' ',#9,#13];
 
710
    end;
 
711
  { scan until the end of the argument }
 
712
    argstart:=pc;
 
713
    while (pc^<>#0) and not(pc^ in quote) do
 
714
     inc(pc);
 
715
    { Don't copy the first one, it is already there.}
 
716
    If Count<>0 then
 
717
     begin
 
718
       { reserve some memory }
 
719
       arglen:=pc-argstart;
 
720
       getmem(argsbuf[count],arglen+1);
 
721
       move(argstart^,argsbuf[count]^,arglen);
 
722
       argsbuf[count][arglen]:=#0;
 
723
     end;
 
724
    { skip quote }
 
725
    if pc^ in quote then
 
726
     inc(pc);
 
727
    inc(count);
 
728
  until false;
 
729
{ create argc }
 
730
  argc:=count;
 
731
{ create an nil entry }
 
732
  argsbuf[count]:=nil;
 
733
  inc(count);
 
734
{ create the argv }
 
735
  getmem(argv,count shl 2);
 
736
  move(argsbuf,argv^,count shl 2);
 
737
{ Setup cmdline variable }
 
738
  cmdline:=GetCommandLine;
 
739
end;
 
740
 
 
741
 
 
742
{*****************************************************************************
 
743
                         System Dependent Exit code
 
744
*****************************************************************************}
 
745
 
 
746
  procedure install_exception_handlers;forward;
 
747
  procedure remove_exception_handlers;forward;
 
748
  procedure PascalMain;external name 'PASCALMAIN';
 
749
  procedure fpc_do_exit;external name 'FPC_DO_EXIT';
 
750
  Procedure ExitDLL(Exitcode : longint); forward;
 
751
 
 
752
Procedure system_exit;
 
753
begin
 
754
  { don't call ExitProcess inside
 
755
    the DLL exit code !!
 
756
    This crashes Win95 at least PM }
 
757
  if IsLibrary then
 
758
    ExitDLL(ExitCode);
 
759
  if not IsConsole then
 
760
   begin
 
761
     Close(stderr);
 
762
     Close(stdout);
 
763
     { what about Input and Output ?? PM }
 
764
   end;
 
765
  remove_exception_handlers;
 
766
  ExitProcess(ExitCode);
 
767
end;
 
768
 
 
769
{$ifdef dummy}
 
770
Function SetUpStack : longint;
 
771
{ This routine does the following :                            }
 
772
{  returns the value of the initial SP - __stklen              }
 
773
begin
 
774
  asm
 
775
    pushl %ebx
 
776
    pushl %eax
 
777
    movl  __stklen,%ebx
 
778
    movl  %esp,%eax
 
779
    subl  %ebx,%eax
 
780
    movl  %eax,__RESULT
 
781
    popl  %eax
 
782
    popl  %ebx
 
783
  end;
 
784
end;
 
785
{$endif}
 
786
 
 
787
 
 
788
var
 
789
  { value of the stack segment
 
790
    to check if the call stack can be written on exceptions }
 
791
  _SS : longint;
 
792
 
 
793
const
 
794
  fpucw : word = $1332;
 
795
 
 
796
procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
 
797
  begin
 
798
     IsLibrary:=false;
 
799
     { install the handlers for exe only ?
 
800
       or should we install them for DLL also ? (PM) }
 
801
     install_exception_handlers;
 
802
     { This strange construction is needed to solve the _SS problem
 
803
       with a smartlinked syswin32 (PFV) }
 
804
     asm
 
805
        pushl %ebp
 
806
        xorl %ebp,%ebp
 
807
        movl %esp,%eax
 
808
        movl %eax,Win32StackTop
 
809
        movw %ss,%bp
 
810
        movl %ebp,_SS
 
811
        fninit
 
812
        fldcw   fpucw
 
813
        xorl %ebp,%ebp
 
814
        call PASCALMAIN
 
815
        popl %ebp
 
816
     end;
 
817
     { if we pass here there was no error ! }
 
818
     system_exit;
 
819
  end;
 
820
 
 
821
Const
 
822
  { DllEntryPoint  }
 
823
     DLL_PROCESS_ATTACH = 1;
 
824
     DLL_THREAD_ATTACH = 2;
 
825
     DLL_PROCESS_DETACH = 0;
 
826
     DLL_THREAD_DETACH = 3;
 
827
Var
 
828
     DLLBuf : Jmp_buf;
 
829
Const
 
830
     DLLExitOK : boolean = true;
 
831
 
 
832
function Dll_entry : longbool;[public, alias : '_FPC_DLL_Entry'];
 
833
var
 
834
  res : longbool;
 
835
 
 
836
  begin
 
837
     IsLibrary:=true;
 
838
     Dll_entry:=false;
 
839
     case DLLreason of
 
840
       DLL_PROCESS_ATTACH :
 
841
         begin
 
842
           If SetJmp(DLLBuf) = 0 then
 
843
             begin
 
844
               if assigned(Dll_Process_Attach_Hook) then
 
845
                 begin
 
846
                   res:=Dll_Process_Attach_Hook(DllParam);
 
847
                   if not res then
 
848
                     exit(false);
 
849
                 end;
 
850
               PASCALMAIN;
 
851
               Dll_entry:=true;
 
852
             end
 
853
           else
 
854
             Dll_entry:=DLLExitOK;
 
855
         end;
 
856
       DLL_THREAD_ATTACH :
 
857
         begin
 
858
           inc(Thread_count);
 
859
           if assigned(Dll_Thread_Attach_Hook) then
 
860
             Dll_Thread_Attach_Hook(DllParam);
 
861
           Dll_entry:=true; { return value is ignored }
 
862
         end;
 
863
       DLL_THREAD_DETACH :
 
864
         begin
 
865
           dec(Thread_count);
 
866
           if assigned(Dll_Thread_Detach_Hook) then
 
867
             Dll_Thread_Detach_Hook(DllParam);
 
868
           Dll_entry:=true; { return value is ignored }
 
869
         end;
 
870
       DLL_PROCESS_DETACH :
 
871
         begin
 
872
           Dll_entry:=true; { return value is ignored }
 
873
           If SetJmp(DLLBuf) = 0 then
 
874
             begin
 
875
               FPC_DO_EXIT;
 
876
             end;
 
877
           if assigned(Dll_Process_Detach_Hook) then
 
878
             Dll_Process_Detach_Hook(DllParam);
 
879
         end;
 
880
     end;
 
881
  end;
 
882
 
 
883
Procedure ExitDLL(Exitcode : longint);
 
884
begin
 
885
    DLLExitOK:=ExitCode=0;
 
886
    LongJmp(DLLBuf,1);
 
887
end;
 
888
 
 
889
{$ifdef Set_i386_Exception_handler}
 
890
 
 
891
const
 
892
     EXCEPTION_MAXIMUM_PARAMETERS = 15;
 
893
     EXCEPTION_ACCESS_VIOLATION = $c0000005;
 
894
     EXCEPTION_BREAKPOINT = $80000003;
 
895
     EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
 
896
     EXCEPTION_SINGLE_STEP = $80000004;
 
897
     EXCEPTION_ARRAY_BOUNDS_EXCEEDED = $c000008c;
 
898
     EXCEPTION_FLT_DENORMAL_OPERAND = $c000008d;
 
899
     EXCEPTION_FLT_DIVIDE_BY_ZERO = $c000008e;
 
900
     EXCEPTION_FLT_INEXACT_RESULT = $c000008f;
 
901
     EXCEPTION_FLT_INVALID_OPERATION = $c0000090;
 
902
     EXCEPTION_FLT_OVERFLOW = $c0000091;
 
903
     EXCEPTION_FLT_STACK_CHECK = $c0000092;
 
904
     EXCEPTION_FLT_UNDERFLOW = $c0000093;
 
905
     EXCEPTION_INT_DIVIDE_BY_ZERO = $c0000094;
 
906
     EXCEPTION_INT_OVERFLOW = $c0000095;
 
907
     EXCEPTION_INVALID_HANDLE = $c0000008;
 
908
     EXCEPTION_PRIV_INSTRUCTION = $c0000096;
 
909
     EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
 
910
     EXCEPTION_NONCONTINUABLE = $1;
 
911
     EXCEPTION_STACK_OVERFLOW = $c00000fd;
 
912
     EXCEPTION_INVALID_DISPOSITION = $c0000026;
 
913
     EXCEPTION_ILLEGAL_INSTRUCTION = $C000001D;
 
914
     EXCEPTION_IN_PAGE_ERROR = $C0000006;
 
915
 
 
916
     EXCEPTION_EXECUTE_HANDLER = 1;
 
917
     EXCEPTION_CONTINUE_EXECUTION = -(1);
 
918
     EXCEPTION_CONTINUE_SEARCH = 0;
 
919
  type
 
920
 
 
921
     FLOATING_SAVE_AREA = record
 
922
          ControlWord : DWORD;
 
923
          StatusWord : DWORD;
 
924
          TagWord : DWORD;
 
925
          ErrorOffset : DWORD;
 
926
          ErrorSelector : DWORD;
 
927
          DataOffset : DWORD;
 
928
          DataSelector : DWORD;
 
929
          RegisterArea : array[0..79] of BYTE;
 
930
          Cr0NpxState : DWORD;
 
931
       end;
 
932
     _FLOATING_SAVE_AREA = FLOATING_SAVE_AREA;
 
933
     TFLOATINGSAVEAREA = FLOATING_SAVE_AREA;
 
934
     PFLOATINGSAVEAREA = ^FLOATING_SAVE_AREA;
 
935
 
 
936
     CONTEXT = record
 
937
          ContextFlags : DWORD;
 
938
          Dr0 : DWORD;
 
939
          Dr1 : DWORD;
 
940
          Dr2 : DWORD;
 
941
          Dr3 : DWORD;
 
942
          Dr6 : DWORD;
 
943
          Dr7 : DWORD;
 
944
          FloatSave : FLOATING_SAVE_AREA;
 
945
          SegGs : DWORD;
 
946
          SegFs : DWORD;
 
947
          SegEs : DWORD;
 
948
          SegDs : DWORD;
 
949
          Edi : DWORD;
 
950
          Esi : DWORD;
 
951
          Ebx : DWORD;
 
952
          Edx : DWORD;
 
953
          Ecx : DWORD;
 
954
          Eax : DWORD;
 
955
          Ebp : DWORD;
 
956
          Eip : DWORD;
 
957
          SegCs : DWORD;
 
958
          EFlags : DWORD;
 
959
          Esp : DWORD;
 
960
          SegSs : DWORD;
 
961
       end;
 
962
     LPCONTEXT = ^CONTEXT;
 
963
     _CONTEXT = CONTEXT;
 
964
     TCONTEXT = CONTEXT;
 
965
     PCONTEXT = ^CONTEXT;
 
966
 
 
967
 
 
968
type pexception_record = ^exception_record;
 
969
     EXCEPTION_RECORD  = record
 
970
       ExceptionCode   : longint;
 
971
       ExceptionFlags  : longint;
 
972
       ExceptionRecord : pexception_record;
 
973
       ExceptionAddress : pointer;
 
974
       NumberParameters : longint;
 
975
       ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of pointer;
 
976
     end;
 
977
 
 
978
     PEXCEPTION_POINTERS = ^EXCEPTION_POINTERS;
 
979
     EXCEPTION_POINTERS = record
 
980
       ExceptionRecord   : PEXCEPTION_RECORD ;
 
981
       ContextRecord     : PCONTEXT ;
 
982
     end;
 
983
 
 
984
     { type of functions that should be used for exception handling }
 
985
     LPTOP_LEVEL_EXCEPTION_FILTER = function(excep :PEXCEPTION_POINTERS) : longint;stdcall;
 
986
 
 
987
     function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : LPTOP_LEVEL_EXCEPTION_FILTER)
 
988
       : LPTOP_LEVEL_EXCEPTION_FILTER;
 
989
       external 'kernel32' name 'SetUnhandledExceptionFilter';
 
990
 
 
991
const
 
992
  MAX_Level = 16;
 
993
  except_level : byte = 0;
 
994
var
 
995
  except_eip   : array[0..Max_level-1] of longint;
 
996
  except_error : array[0..Max_level-1] of byte;
 
997
  reset_fpu    : array[0..max_level-1] of boolean;
 
998
 
 
999
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1000
  procedure DebugHandleErrorAddrFrame(error, addr, frame : longint);
 
1001
    begin
 
1002
      if IsConsole then
 
1003
        begin
 
1004
          write(stderr,'call to HandleErrorAddrFrame(error=',error);
 
1005
          write(stderr,',addr=',hexstr(addr,8));
 
1006
          writeln(stderr,',frame=',hexstr(frame,8),')');
 
1007
        end;
 
1008
      HandleErrorAddrFrame(error,addr,frame);
 
1009
    end;
 
1010
{$endif SYSTEMEXCEPTIONDEBUG}
 
1011
 
 
1012
  procedure JumpToHandleErrorFrame;
 
1013
    var
 
1014
      eip,ebp,error : longint;
 
1015
    begin
 
1016
      asm
 
1017
        movl (%ebp),%eax
 
1018
        movl %eax,ebp
 
1019
      end;
 
1020
      if except_level>0 then
 
1021
        dec(except_level);
 
1022
      eip:=except_eip[except_level];
 
1023
      error:=except_error[except_level];
 
1024
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1025
      if IsConsole then
 
1026
        begin
 
1027
          writeln(stderr,'In JumpToHandleErrorFrame error=',error);
 
1028
        end;
 
1029
{$endif SYSTEMEXCEPTIONDEBUG}
 
1030
      if reset_fpu[except_level] then
 
1031
        asm
 
1032
          fninit
 
1033
          fldcw   fpucw
 
1034
        end;
 
1035
      { build a fake stack }
 
1036
      asm
 
1037
        movl   ebp,%eax
 
1038
        pushl  %eax
 
1039
        movl   eip,%eax
 
1040
        pushl  %eax
 
1041
        movl   error,%eax
 
1042
        pushl  %eax
 
1043
        movl   eip,%eax
 
1044
        pushl  %eax
 
1045
        movl   ebp,%ebp // Change frame pointer
 
1046
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1047
        jmpl   DebugHandleErrorAddrFrame
 
1048
{$else not SYSTEMEXCEPTIONDEBUG}
 
1049
        jmpl   HandleErrorAddrFrame
 
1050
{$endif SYSTEMEXCEPTIONDEBUG}
 
1051
      end;
 
1052
 
 
1053
    end;
 
1054
 
 
1055
  function syswin32_i386_exception_handler(excep :PEXCEPTION_POINTERS) : longint;stdcall;
 
1056
    var frame,res  : longint;
 
1057
        function SysHandleErrorFrame(error,frame : longint;must_reset_fpu : boolean) : longint;
 
1058
          begin
 
1059
            if frame=0 then
 
1060
              SysHandleErrorFrame:=Exception_Continue_Search
 
1061
            else
 
1062
              begin
 
1063
                 if except_level >= Max_level then
 
1064
                   exit;
 
1065
                 except_eip[except_level]:=excep^.ContextRecord^.Eip;
 
1066
                 except_error[except_level]:=error;
 
1067
                 reset_fpu[except_level]:=must_reset_fpu;
 
1068
                 inc(except_level);
 
1069
                 excep^.ContextRecord^.Eip:=longint(@JumpToHandleErrorFrame);
 
1070
                 excep^.ExceptionRecord^.ExceptionCode:=0;
 
1071
                 SysHandleErrorFrame:=Exception_Continue_Execution;
 
1072
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1073
                 if IsConsole then
 
1074
                   begin
 
1075
                     writeln(stderr,'Exception Continue Exception set at ',
 
1076
                       hexstr(except_eip[except_level],8));
 
1077
                     writeln(stderr,'Eip changed to ',
 
1078
                       hexstr(longint(@JumpToHandleErrorFrame),8), ' error=',error);
 
1079
                   end;
 
1080
{$endif SYSTEMEXCEPTIONDEBUG}
 
1081
              end;
 
1082
          end;
 
1083
 
 
1084
    begin
 
1085
       if excep^.ContextRecord^.SegSs=_SS then
 
1086
         frame:=excep^.ContextRecord^.Ebp
 
1087
       else
 
1088
         frame:=0;
 
1089
       { default : unhandled !}
 
1090
       res:=Exception_Continue_Search;
 
1091
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1092
       if IsConsole then
 
1093
         writeln(stderr,'Exception  ',
 
1094
           hexstr(excep^.ExceptionRecord^.ExceptionCode,8));
 
1095
{$endif SYSTEMEXCEPTIONDEBUG}
 
1096
       case excep^.ExceptionRecord^.ExceptionCode of
 
1097
         EXCEPTION_ACCESS_VIOLATION :
 
1098
           res:=SysHandleErrorFrame(216,frame,false);
 
1099
         { EXCEPTION_BREAKPOINT = $80000003;
 
1100
         EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
 
1101
         EXCEPTION_SINGLE_STEP = $80000004; }
 
1102
         EXCEPTION_ARRAY_BOUNDS_EXCEEDED :
 
1103
           res:=SysHandleErrorFrame(201,frame,false);
 
1104
         EXCEPTION_FLT_DENORMAL_OPERAND :
 
1105
           begin
 
1106
             res:=SysHandleErrorFrame(216,frame,true);
 
1107
           end;
 
1108
         EXCEPTION_FLT_DIVIDE_BY_ZERO :
 
1109
           begin
 
1110
             res:=SysHandleErrorFrame(200,frame,true);
 
1111
             {excep^.ContextRecord^.FloatSave.StatusWord:=excep^.ContextRecord^.FloatSave.StatusWord and $ffffff00;}
 
1112
           end;
 
1113
         {EXCEPTION_FLT_INEXACT_RESULT = $c000008f; }
 
1114
         EXCEPTION_FLT_INVALID_OPERATION :
 
1115
           begin
 
1116
             res:=SysHandleErrorFrame(207,frame,true);
 
1117
           end;
 
1118
         EXCEPTION_FLT_OVERFLOW :
 
1119
           begin
 
1120
             res:=SysHandleErrorFrame(205,frame,true);
 
1121
           end;
 
1122
         EXCEPTION_FLT_STACK_CHECK :
 
1123
           begin
 
1124
             res:=SysHandleErrorFrame(207,frame,true);
 
1125
           end;
 
1126
         EXCEPTION_FLT_UNDERFLOW :
 
1127
           begin
 
1128
             res:=SysHandleErrorFrame(206,frame,true); { should be accepted as zero !! }
 
1129
           end;
 
1130
         EXCEPTION_INT_DIVIDE_BY_ZERO :
 
1131
           res:=SysHandleErrorFrame(200,frame,false);
 
1132
         EXCEPTION_INT_OVERFLOW :
 
1133
           res:=SysHandleErrorFrame(215,frame,false);
 
1134
         {EXCEPTION_INVALID_HANDLE = $c0000008;
 
1135
         EXCEPTION_PRIV_INSTRUCTION = $c0000096;
 
1136
         EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
 
1137
         EXCEPTION_NONCONTINUABLE = $1;}
 
1138
         EXCEPTION_STACK_OVERFLOW :
 
1139
           res:=SysHandleErrorFrame(202,frame,false);
 
1140
         {EXCEPTION_INVALID_DISPOSITION = $c0000026;}
 
1141
         EXCEPTION_ILLEGAL_INSTRUCTION,
 
1142
         EXCEPTION_PRIV_INSTRUCTION,
 
1143
         EXCEPTION_IN_PAGE_ERROR,
 
1144
         EXCEPTION_SINGLE_STEP : res:=SysHandleErrorFrame(217,frame,false);
 
1145
         end;
 
1146
       syswin32_i386_exception_handler:=res;
 
1147
    end;
 
1148
 
 
1149
 
 
1150
  procedure install_exception_handlers;
 
1151
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1152
    var
 
1153
      oldexceptaddr,newexceptaddr : longint;
 
1154
{$endif SYSTEMEXCEPTIONDEBUG}
 
1155
    begin
 
1156
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1157
      asm
 
1158
        movl $0,%eax
 
1159
        movl %fs:(%eax),%eax
 
1160
        movl %eax,oldexceptaddr
 
1161
      end;
 
1162
{$endif SYSTEMEXCEPTIONDEBUG}
 
1163
      SetUnhandledExceptionFilter(@syswin32_i386_exception_handler);
 
1164
{$ifdef SYSTEMEXCEPTIONDEBUG}
 
1165
      asm
 
1166
        movl $0,%eax
 
1167
        movl %fs:(%eax),%eax
 
1168
        movl %eax,newexceptaddr
 
1169
      end;
 
1170
      if IsConsole then
 
1171
        writeln(stderr,'Old exception  ',hexstr(oldexceptaddr,8),
 
1172
          ' new exception  ',hexstr(newexceptaddr,8));
 
1173
{$endif SYSTEMEXCEPTIONDEBUG}
 
1174
    end;
 
1175
 
 
1176
  procedure remove_exception_handlers;
 
1177
    begin
 
1178
      SetUnhandledExceptionFilter(nil);
 
1179
    end;
 
1180
 
 
1181
{$else not i386 (Processor specific !!)}
 
1182
  procedure install_exception_handlers;
 
1183
    begin
 
1184
    end;
 
1185
 
 
1186
  procedure remove_exception_handlers;
 
1187
    begin
 
1188
    end;
 
1189
 
 
1190
{$endif Set_i386_Exception_handler}
 
1191
 
 
1192
 
 
1193
{****************************************************************************
 
1194
                    Error Message writing using messageboxes
 
1195
****************************************************************************}
 
1196
 
 
1197
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
 
1198
   external 'user32' name 'MessageBoxA';
 
1199
 
 
1200
const
 
1201
  ErrorBufferLength = 1024;
 
1202
var
 
1203
  ErrorBuf : array[0..ErrorBufferLength] of char;
 
1204
  ErrorLen : longint;
 
1205
 
 
1206
Function ErrorWrite(Var F: TextRec): Integer;
 
1207
{
 
1208
  An error message should always end with #13#10#13#10
 
1209
}
 
1210
var
 
1211
  p : pchar;
 
1212
  i : longint;
 
1213
Begin
 
1214
  if F.BufPos>0 then
 
1215
   begin
 
1216
     if F.BufPos+ErrorLen>ErrorBufferLength then
 
1217
       i:=ErrorBufferLength-ErrorLen
 
1218
     else
 
1219
       i:=F.BufPos;
 
1220
     Move(F.BufPtr^,ErrorBuf[ErrorLen],i);
 
1221
     inc(ErrorLen,i);
 
1222
     ErrorBuf[ErrorLen]:=#0;
 
1223
   end;
 
1224
  if ErrorLen>3 then
 
1225
   begin
 
1226
     p:=@ErrorBuf[ErrorLen];
 
1227
     for i:=1 to 4 do
 
1228
      begin
 
1229
        dec(p);
 
1230
        if not(p^ in [#10,#13]) then
 
1231
         break;
 
1232
      end;
 
1233
   end;
 
1234
   if ErrorLen=ErrorBufferLength then
 
1235
     i:=4;
 
1236
   if (i=4) then
 
1237
    begin
 
1238
      MessageBox(0,@ErrorBuf,pchar('Error'),0);
 
1239
      ErrorLen:=0;
 
1240
    end;
 
1241
  F.BufPos:=0;
 
1242
  ErrorWrite:=0;
 
1243
End;
 
1244
 
 
1245
 
 
1246
Function ErrorClose(Var F: TextRec): Integer;
 
1247
begin
 
1248
  if ErrorLen>0 then
 
1249
   begin
 
1250
     MessageBox(0,@ErrorBuf,pchar('Error'),0);
 
1251
     ErrorLen:=0;
 
1252
   end;
 
1253
  ErrorLen:=0;
 
1254
  ErrorClose:=0;
 
1255
end;
 
1256
 
 
1257
 
 
1258
Function ErrorOpen(Var F: TextRec): Integer;
 
1259
Begin
 
1260
  TextRec(F).InOutFunc:=@ErrorWrite;
 
1261
  TextRec(F).FlushFunc:=@ErrorWrite;
 
1262
  TextRec(F).CloseFunc:=@ErrorClose;
 
1263
  ErrorOpen:=0;
 
1264
End;
 
1265
 
 
1266
 
 
1267
procedure AssignError(Var T: Text);
 
1268
begin
 
1269
  Assign(T,'');
 
1270
  TextRec(T).OpenFunc:=@ErrorOpen;
 
1271
  Rewrite(T);
 
1272
end;
 
1273
 
 
1274
 
 
1275
 
 
1276
const
 
1277
   Exe_entry_code : pointer = @Exe_entry;
 
1278
   Dll_entry_code : pointer = @Dll_entry;
 
1279
 
 
1280
begin
 
1281
{ get some helpful informations }
 
1282
  GetStartupInfo(@startupinfo);
 
1283
{ some misc Win32 stuff }
 
1284
  hprevinst:=0;
 
1285
  if not IsLibrary then
 
1286
    HInstance:=getmodulehandle(GetCommandFile);
 
1287
  MainInstance:=HInstance;
 
1288
  { No idea how to know this issue !! }
 
1289
  IsMultithreaded:=false;
 
1290
  cmdshow:=startupinfo.wshowwindow;
 
1291
{ to test stack depth }
 
1292
  loweststack:=maxlongint;
 
1293
{ real test stack depth        }
 
1294
{   stacklimit := setupstack;  }
 
1295
{ Setup heap }
 
1296
  InitHeap;
 
1297
  InitExceptions;
 
1298
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
 
1299
  displayed in and messagebox }
 
1300
  StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
 
1301
  StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
 
1302
  StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));
 
1303
  if not IsConsole then
 
1304
   begin
 
1305
     AssignError(stderr);
 
1306
     AssignError(stdout);
 
1307
     Assign(Output,'');
 
1308
     Assign(Input,'');
 
1309
   end
 
1310
  else
 
1311
   begin
 
1312
     OpenStdIO(Input,fmInput,StdInputHandle);
 
1313
     OpenStdIO(Output,fmOutput,StdOutputHandle);
 
1314
     OpenStdIO(StdOut,fmOutput,StdOutputHandle);
 
1315
     OpenStdIO(StdErr,fmOutput,StdErrorHandle);
 
1316
   end;
 
1317
{ Arguments }
 
1318
  setup_arguments;
 
1319
{ Reset IO Error }
 
1320
  InOutRes:=0;
 
1321
{ Reset internal error variable }
 
1322
  errno:=0;
 
1323
end.
 
1324
 
 
1325
{
 
1326
  $Log: syswin32.pp,v $
 
1327
  Revision 1.1.2.1  2000/10/02 22:15:39  pierre
 
1328
   * all callbacks are stdcall functions
 
1329
 
 
1330
  Revision 1.1  2000/07/13 06:31:22  michael
 
1331
  + Initial import
 
1332
 
 
1333
  Revision 1.65  2000/06/22 18:39:14  peter
 
1334
    * moved islibrary,isconsole,ismulithread to systemh as they are
 
1335
      os independent
 
1336
 
 
1337
  Revision 1.64  2000/05/08 13:25:34  peter
 
1338
    * defined filemode constants in windows unit
 
1339
 
 
1340
  Revision 1.63  2000/03/31 23:21:19  pierre
 
1341
    * multiple exception handling works
 
1342
      (for linux only if syslinux is compiled with -dnewsignal)
 
1343
 
 
1344
  Revision 1.62  2000/03/16 20:42:26  michael
 
1345
  + Added more system exception handling afte T. Schatzl remark
 
1346
 
 
1347
  Revision 1.61  2000/03/10 09:21:11  pierre
 
1348
    * ExitDLL fixed : uses now SetJmp LongJmp
 
1349
    * System_exit unloads the exception hanlder before leaving
 
1350
 
 
1351
  Revision 1.60  2000/02/09 16:59:34  peter
 
1352
    * truncated log
 
1353
 
 
1354
  Revision 1.59  2000/02/09 12:24:39  peter
 
1355
    * halt moved to system.inc
 
1356
 
 
1357
  Revision 1.58  2000/01/20 23:38:02  peter
 
1358
    * support fm_inout as stdoutput for assign(f,'');rewrite(f,1); becuase
 
1359
      rewrite opens always with filemode 2
 
1360
 
 
1361
  Revision 1.57  2000/01/18 09:03:04  pierre
 
1362
    * DLL crash fixed : ExitProcess can not be called in DLL system_exit
 
1363
      Problem : Halt or RunError code inside DLL will return to caller !!
 
1364
    * Changed the "if h<4 then" into "if do_isdevice(h) then " in do_close
 
1365
      to avoid closing of standard files
 
1366
 
 
1367
  Revision 1.56  2000/01/16 23:05:03  peter
 
1368
    * fixed typo
 
1369
 
 
1370
  Revision 1.55  2000/01/16 22:25:38  peter
 
1371
    * check handle for file closing
 
1372
 
 
1373
  Revision 1.54  2000/01/07 16:41:52  daniel
 
1374
    * copyright 2000
 
1375
 
 
1376
  Revision 1.53  2000/01/07 16:32:34  daniel
 
1377
    * copyright 2000 added
 
1378
 
 
1379
  Revision 1.52  2000/01/06 23:40:36  peter
 
1380
    * fixed exitprocess call, it's now in system_exit and uses exitcode
 
1381
 
 
1382
  Revision 1.51  1999/12/01 22:57:31  peter
 
1383
    * cmdline support
 
1384
 
 
1385
  Revision 1.50  1999/11/20 00:16:44  pierre
 
1386
   + DLL Hooks for the four callings added
 
1387
 
 
1388
  Revision 1.49  1999/11/18 22:19:57  pierre
 
1389
   * bug fix for web bug703 and 704
 
1390
 
 
1391
  Revision 1.48  1999/11/09 22:34:00  pierre
 
1392
    * Check ErrorBuf at exit
 
1393
    + Win32StackTop
 
1394
 
 
1395
  Revision 1.47  1999/10/26 12:25:51  peter
 
1396
    * report stderr,stdout to message box for errors
 
1397
    * close input,output when GUI app is made
 
1398
 
 
1399
  Revision 1.46  1999/10/22 14:47:19  peter
 
1400
    * allocate an extra byte for argv[0]
 
1401
 
 
1402
  Revision 1.45  1999/10/03 19:39:05  peter
 
1403
    * fixed argv[0] length
 
1404
 
 
1405
  Revision 1.44  1999/09/10 15:40:35  peter
 
1406
    * fixed do_open flags to be > $100, becuase filemode can be upto 255
 
1407
 
 
1408
}
 
 
b'\\ No newline at end of file'