1 {
2 ****************************************************************************
3
4 This file is part of the Free Pascal run time library.
5 Copyright (c) 1999-2002 by Free Pascal development team
6
7 Free Pascal - EMX runtime library
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
18 unit System;
19
20 interface
21
22 {Link the startup code.}
23 {$l prt1.o}
24
25 {$define FPC_SYSTEM_HAS_SYSDLH}
26
27 {$I systemh.inc}
28
29 const
30 (* Are file sizes > 2 GB (64-bit) supported on the current system? *)
31 FSApi64: boolean = false;
32 (* Is full Unicode support provided by the underlying OS/2 version available *)
33 (* and successfully initialized (otherwise dummy routines need to be used). *)
34 UniAPI: boolean = false;
35 DosCallsHandle: THandle = THandle (-1);
36
37 LineEnding = #13#10;
38 { LFNSupport is defined separately below!!! }
39 DirectorySeparator = '\';
40 DriveSeparator = ':';
41 ExtensionSeparator = '.';
42 PathSeparator = ';';
43 AllowDirectorySeparators : set of char = ['\','/'];
44 AllowDriveSeparators : set of char = [':'];
45 { FileNameCaseSensitive and FileNameCasePreserving are defined separately below!!! }
46 maxExitCode = 255;
47 MaxPathLen = 256;
48 AllFilesMask = '*';
49
50 type Tos=(osDOS,osOS2,osDPMI);
51
52 var os_mode:Tos;
53 first_meg:pointer;
54
55 type TByteArray = array [0..$ffff] of byte;
56 PByteArray = ^TByteArray;
57
58 TSysThreadIB = record
59 TID,
60 Priority,
61 Version: cardinal;
62 MCCount,
63 MCForceFlag: word;
64 end;
65 PSysThreadIB = ^TSysThreadIB;
66
67 TThreadInfoBlock = record
68 PExChain,
69 Stack,
70 StackLimit: pointer;
71 TIB2: PSysThreadIB;
72 Version,
73 Ordinal: cardinal;
74 end;
75 PThreadInfoBlock = ^TThreadInfoBlock;
76 PPThreadInfoBlock = ^PThreadInfoBlock;
77
78 TProcessInfoBlock = record
79 PID,
80 ParentPid,
81 Handle: cardinal;
82 Cmd,
83 Env: PByteArray;
84 Status,
85 ProcType: cardinal;
86 end;
87 PProcessInfoBlock = ^TProcessInfoBlock;
88 PPProcessInfoBlock = ^PProcessInfoBlock;
89
90 const UnusedHandle=-1;
91 StdInputHandle=0;
92 StdOutputHandle=1;
93 StdErrorHandle=2;
94
95 LFNSupport: boolean = true;
96 FileNameCaseSensitive: boolean = false;
97 FileNameCasePreserving: boolean = false;
98 CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
99
100 sLineBreak = LineEnding;
101 DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
102
103 var
104 { C-compatible arguments and environment }
105 argc : longint;external name '_argc';
106 argv : ppchar;external name '_argv';
107 envp : ppchar;external name '_environ';
108 EnvC: cardinal; external name '_envc';
109
110 (* Pointer to the block of environment variables - used e.g. in unit Dos. *)
111 Environment: PChar;
112
113 var
114 (* Type / run mode of the current process: *)
115 (* 0 .. full screen OS/2 session *)
116 (* 1 .. DOS session *)
117 (* 2 .. VIO windowable OS/2 session *)
118 (* 3 .. Presentation Manager OS/2 session *)
119 (* 4 .. detached (background) OS/2 process *)
120 ApplicationType: cardinal;
121
122
123 procedure SetDefaultOS2FileType (FType: ShortString);
124
125 procedure SetDefaultOS2Creator (Creator: ShortString);
126
127 (* Support for tracking I/O errors returned by OS/2 API calls - emulation *)
128 (* of GetLastError / fpGetError functionality used e.g. in Sysutils. *)
129 type
130 TOSErrorWatch = procedure (Error: cardinal);
131
132 procedure NoErrorTracking (Error: cardinal);
133
134 (* This shall be invoked whenever a non-zero error is returned by OS/2 APIs *)
135 (* used in the RTL. Direct OS/2 API calls in user programs are not covered! *)
136 const
137 OSErrorWatch: TOSErrorWatch = @NoErrorTracking;
138
139 type
140 TDosOpenL = function (FileName: PChar; var Handle: THandle;
141 var Action: cardinal; InitSize: int64;
142 Attrib, OpenFlags, FileMode: cardinal;
143 EA: pointer): cardinal; cdecl;
144
145 TDosSetFilePtrL = function (Handle: THandle; Pos: int64; Method: cardinal;
146 var PosActual: int64): cardinal; cdecl;
147
148 TDosSetFileSizeL = function (Handle: THandle; Size: int64): cardinal; cdecl;
149
150
151 var
152 Sys_DosOpenL: TDosOpenL;
153 Sys_DosSetFilePtrL: TDosSetFilePtrL;
154 Sys_DosSetFileSizeL: TDosSetFileSizeL;
155
156
157 implementation
158
159 { EMX cross-assembler is way too old to support 64bit opcodes }
160 {$define OLD_ASSEMBLER}
161
162 {$I system.inc}
163
164 var
165 heap_base: pointer; external name '__heap_base';
166 heap_brk: pointer; external name '__heap_brk';
167 heap_end: pointer; external name '__heap_end';
168
169 (* Maximum heap size - only used if heap is allocated as continuous block. *)
170 {$IFDEF CONTHEAP}
171 BrkLimit: cardinal;
172 {$ENDIF CONTHEAP}
173
174
175 {****************************************************************************
176
177 Miscellaneous related routines.
178
179 ****************************************************************************}
180
181 {$asmmode intel}
182 procedure system_exit; assembler;
183 asm
184 mov ah, 04ch
185 mov al, byte ptr exitcode
186 call syscall
187 end {['EAX']};
188
189 {$ASMMODE ATT}
190
paramcountnull191 function paramcount:longint;assembler;
192
193 asm
194 movl argc,%eax
195 decl %eax
196 end {['EAX']};
197
argsnull198 function args:pointer;assembler;
199
200 asm
201 movl argv,%eax
202 end {['EAX']};
203
204
paramstrnull205 function paramstr(l:longint):string;
206
207 var p:^Pchar;
208
209 begin
210 { There seems to be a problem with EMX for DOS when trying to }
211 { access paramstr(0), and to avoid problems between DOS and }
212 { OS/2 they have been separated. }
213 if os_Mode = OsOs2 then
214 begin
215 if L = 0 then
216 begin
217 GetMem (P, 260);
218 p[0] := #0; { in case of error, initialize to empty string }
219 {$ASMMODE INTEL}
220 asm
221 mov edx, P
222 mov ecx, 260
223 mov eax, 7F33h
224 call syscall { error handle already with empty string }
225 end ['eax', 'ecx', 'edx'];
226 ParamStr := StrPas (PChar (P));
227 FreeMem (P, 260);
228 end
229 else
230 if (l>0) and (l<=paramcount) then
231 begin
232 p:=args;
233 paramstr:=strpas(p[l]);
234 end
235 else paramstr:='';
236 end
237 else
238 begin
239 p:=args;
240 paramstr:=strpas(p[l]);
241 end;
242 end;
243
244
245 procedure randomize; assembler;
246 asm
247 mov ah, 2Ch
248 call syscall
249 mov word ptr [randseed], cx
250 mov word ptr [randseed + 2], dx
251 end {['eax', 'ecx', 'edx']};
252
253 {$ASMMODE ATT}
254
255
256 {*****************************************************************************
257
258 System unit initialization.
259
260 ****************************************************************************}
261
262 {****************************************************************************
263 Error Message writing using messageboxes
264 ****************************************************************************}
265
266 type
267 TWinMessageBox = function (Parent, Owner: cardinal;
268 BoxText, BoxTitle: PChar; Identity, Style: cardinal): cardinal; cdecl;
269 TWinInitialize = function (Options: cardinal): cardinal; cdecl;
270 TWinCreateMsgQueue = function (Handle: cardinal; cmsg: longint): cardinal;
271 cdecl;
272
273 const
274 ErrorBufferLength = 1024;
275 mb_OK = $0000;
276 mb_Error = $0040;
277 mb_Moveable = $4000;
278 MBStyle = mb_OK or mb_Error or mb_Moveable;
279 WinInitialize: TWinInitialize = nil;
280 WinCreateMsgQueue: TWinCreateMsgQueue = nil;
281 WinMessageBox: TWinMessageBox = nil;
282 EnvSize: cardinal = 0;
283
284 var
285 ErrorBuf: array [0..ErrorBufferLength] of char;
286 ErrorLen: longint;
287 PMWinHandle: cardinal;
288
ErrorWritenull289 function ErrorWrite (var F: TextRec): integer;
290 {
291 An error message should always end with #13#10#13#10
292 }
293 var
294 P: PChar;
295 I: longint;
296 begin
297 if F.BufPos > 0 then
298 begin
299 if F.BufPos + ErrorLen > ErrorBufferLength then
300 I := ErrorBufferLength - ErrorLen
301 else
302 I := F.BufPos;
303 Move (F.BufPtr^, ErrorBuf [ErrorLen], I);
304 Inc (ErrorLen, I);
305 ErrorBuf [ErrorLen] := #0;
306 end;
307 if ErrorLen > 3 then
308 begin
309 P := @ErrorBuf [ErrorLen];
310 for I := 1 to 4 do
311 begin
312 Dec (P);
313 if not (P^ in [#10, #13]) then
314 break;
315 end;
316 end;
317 if ErrorLen = ErrorBufferLength then
318 I := 4;
319 if (I = 4) then
320 begin
321 WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
322 ErrorLen := 0;
323 end;
324 F.BufPos := 0;
325 ErrorWrite := 0;
326 end;
327
ErrorClosenull328 function ErrorClose (var F: TextRec): integer;
329 begin
330 if ErrorLen > 0 then
331 begin
332 WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
333 ErrorLen := 0;
334 end;
335 ErrorLen := 0;
336 ErrorClose := 0;
337 end;
338
ErrorOpennull339 function ErrorOpen (var F: TextRec): integer;
340 begin
341 TextRec(F).InOutFunc := @ErrorWrite;
342 TextRec(F).FlushFunc := @ErrorWrite;
343 TextRec(F).CloseFunc := @ErrorClose;
344 ErrorOpen := 0;
345 end;
346
347
348 procedure AssignError (var T: Text);
349 begin
350 Assign (T, '');
351 TextRec (T).OpenFunc := @ErrorOpen;
352 Rewrite (T);
353 end;
354
355
356 procedure DosEnvInit;
357 var
358 Q: PPChar;
359 I: cardinal;
360 begin
361 (* It's a hack, in fact - DOS stores the environment the same way as OS/2 does,
362 but I don't know how to find Program Segment Prefix and thus the environment
363 address under EMX, so I'm recreating this structure using EnvP pointer. *)
364 {$ASMMODE INTEL}
365 asm
366 cld
367 mov ecx, EnvC
368 mov esi, EnvP
369 xor eax, eax
370 xor edx, edx
371 @L1:
372 xchg eax, edx
373 push ecx
374 mov ecx, -1
375 mov edi, [esi]
376 repne
377 scasb
378 neg ecx
379 dec ecx
380 xchg eax, edx
381 add eax, ecx
382 pop ecx
383 dec ecx
384 jecxz @Stop
385 inc esi
386 inc esi
387 inc esi
388 inc esi
389 jmp @L1
390 @Stop:
391 inc eax
392 mov EnvSize, eax
393 end ['eax','ecx','edx','esi','edi'];
394 Environment := GetMem (EnvSize);
395 asm
396 cld
397 mov ecx, EnvC
398 mov edx, EnvP
399 mov edi, Environment
400 @L2:
401 mov esi, [edx]
402 @Copying:
403 lodsb
404 stosb
405 or al, al
406 jnz @Copying
407 dec ecx
408 jecxz @Stop2
409 inc edx
410 inc edx
411 inc edx
412 inc edx
413 jmp @L2
414 @Stop2:
415 stosb
416 end ['eax','ecx','edx','esi','edi'];
417 end;
418
419
420 procedure SysInitStdIO;
421 begin
422 { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
423 displayed in a messagebox }
424 (*
425 StdInputHandle := longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
426 StdOutputHandle := longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
427 StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
428
429 if not IsConsole then
430 begin
431 if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and
432 (DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0)
433 and
434 (DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0)
435 and
436 (DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue))
437 = 0)
438 then
439 begin
440 WinInitialize (0);
441 WinCreateMsgQueue (0, 0);
442 end
443 else
444 HandleError (2);
445 AssignError (StdErr);
446 AssignError (StdOut);
447 Assign (Output, '');
448 Assign (Input, '');
449 end
450 else
451 begin
452 *)
453 OpenStdIO (Input, fmInput, StdInputHandle);
454 OpenStdIO (Output, fmOutput, StdOutputHandle);
455 OpenStdIO (ErrOutput, fmOutput, StdErrorHandle);
456 OpenStdIO (StdOut, fmOutput, StdOutputHandle);
457 OpenStdIO (StdErr, fmOutput, StdErrorHandle);
458 (*
459 end;
460 *)
461 end;
462
463
464 threadvar
465 DefaultCreator: ShortString;
466 DefaultFileType: ShortString;
467
468
469 procedure SetDefaultOS2FileType (FType: ShortString);
470 begin
471 {$WARNING Not implemented yet!}
472 DefaultFileType := FType;
473 end;
474
475
476 procedure SetDefaultOS2Creator (Creator: ShortString);
477 begin
478 {$WARNING Not implemented yet!}
479 DefaultCreator := Creator;
480 end;
481
482 (* The default handler does not store the OS/2 API error codes. *)
483 procedure NoErrorTracking (Error: cardinal);
484 begin
485 end;
486
GetFileHandleCountnull487 function GetFileHandleCount: longint;
488 var L1: longint;
489 L2: cardinal;
490 begin
491 L1 := 0; (* Don't change the amount, just check. *)
492 if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
493 else GetFileHandleCount := L2;
494 end;
495
CheckInitialStkLennull496 function CheckInitialStkLen (StkLen: SizeUInt): SizeUInt;
497 begin
498 CheckInitialStkLen := StkLen;
499 end;
500
501 var TIB: PThreadInfoBlock;
502 PIB: PProcessInfoBlock;
503
504 const
505 FatalHeap: array [0..33] of char = 'FATAL: Cannot initialize heap!!'#13#10'$';
506
507 begin
508 {Determine the operating system we are running on.}
509 {$ASMMODE INTEL}
510 asm
511 push ebx
512 mov os_mode, 0
513 mov eax, 7F0Ah
514 call syscall
515 test bx, 512 {Bit 9 is OS/2 flag.}
516 setne byte ptr os_mode
517 test bx, 4096
518 jz @noRSX
519 mov os_mode, 2
520 @noRSX:
521 {Enable the brk area by initializing it with the initial heap size.}
522 mov eax, 7F01h
523 mov edx, heap_brk
524 add edx, heap_base
525 call syscall
526 cmp eax, -1
527 jnz @heapok
528 lea edx, FatalHeap
529 mov eax, 900h
530 call syscall
531 pop ebx
532 push dword 204
533 call HandleError
534 @heapok:
535 {$IFDEF CONTHEAP}
536 { Find out brk limit }
537 mov eax, 7F02h
538 mov ecx, 3
539 call syscall
540 jcxz @heaplimitknown
541 mov eax, 0
542 @heaplimitknown:
543 mov BrkLimit, eax
544 {$ELSE CONTHEAP}
545 { Change sbrk behaviour to allocate arbitrary (non-contiguous) memory blocks }
546 mov eax, 7F0Fh
547 mov ecx, 0Ch
548 mov edx, 8
549 call syscall
550 {$ENDIF CONTHEAP}
551 pop ebx
552 end ['eax', 'ecx', 'edx'];
553 { in OS/2 this will always be nil, but in DOS mode }
554 { this can be changed. }
555 first_meg := nil;
556 {Now request, if we are running under DOS,
557 read-access to the first meg. of memory.}
558 if os_mode in [osDOS,osDPMI] then
559 asm
560 push ebx
561 mov eax, 7F13h
562 xor ebx, ebx
563 mov ecx, 0FFFh
564 xor edx, edx
565 call syscall
566 jc @endmem
567 mov first_meg, eax
568 @endmem:
569 pop ebx
570 end ['eax', 'ecx', 'edx']
571 else
572 begin
573 (* Initialize the amount of file handles *)
574 FileHandleCount := GetFileHandleCount;
575 end;
576 {At 0.9.2, case for enumeration does not work.}
577 case os_mode of
578 osDOS:
579 begin
580 stackbottom:=pointer(heap_brk); {In DOS mode, heap_brk is
581 also the stack bottom.}
582 StackLength:=sptr-stackbottom;
583 {$WARNING To be checked/corrected!}
584 ApplicationType := 1; (* Running under DOS. *)
585 IsConsole := true;
586 asm
587 mov ax, 7F05h
588 call syscall
589 mov ProcessID, eax
590 end ['eax'];
591 ThreadID := 1;
592 end;
593 osOS2:
594 begin
595 DosGetInfoBlocks (@TIB, @PIB);
596 StackLength:=CheckInitialStkLen(InitialStklen);
597 { OS/2 has top of stack in TIB^.StackLimit - unlike Windows where it is in TIB^.Stack }
598 StackBottom := TIB^.StackLimit - StackLength;
599
600 Environment := pointer (PIB^.Env);
601 ApplicationType := PIB^.ProcType;
602 ProcessID := PIB^.PID;
603 ThreadID := TIB^.TIB2^.TID;
604 IsConsole := ApplicationType <> 3;
605 FileNameCasePreserving := true;
606 end;
607 osDPMI:
608 begin
609 stackbottom:=nil; {Not sure how to get it, but seems to be
610 always zero.}
611 StackLength:=sptr-stackbottom;
612 {$WARNING To be checked/corrected!}
613 ApplicationType := 1; (* Running under DOS. *)
614 IsConsole := true;
615 ThreadID := 1;
616 end;
617 end;
618 exitproc:=nil;
619
620 {Initialize the heap.}
621 initheap;
622
623 { ... and exceptions }
624 SysInitExceptions;
625
626 {$ifdef HASWIDESTRING}
627 InitUnicodeStringManager;
628 {$endif HASWIDESTRING}
629
630 { ... and I/O }
631 SysInitStdIO;
632
633 { no I/O-Error }
634 inoutres:=0;
635
636 InitSystemThreads;
637
638 InitSystemDynLibs;
639
640 if os_Mode in [osDOS,osDPMI] then
641 DosEnvInit;
642
643 {$IFDEF DUMPGROW}
644 {$IFDEF CONTHEAP}
645 WriteLn ('Initial brk size is ', GetHeapSize);
646 WriteLn ('Brk limit is ', BrkLimit);
647 {$ENDIF CONTHEAP}
648 {$ENDIF DUMPGROW}
649 end.
650