diff options
Diffstat (limited to 'rtl/emx/system.pas')
| -rw-r--r-- | rtl/emx/system.pas | 603 |
1 files changed, 603 insertions, 0 deletions
diff --git a/rtl/emx/system.pas b/rtl/emx/system.pas new file mode 100644 index 0000000000..2ed1c52899 --- /dev/null +++ b/rtl/emx/system.pas @@ -0,0 +1,603 @@ +{ + $Id: system.pas,v 1.35 2005/04/03 21:10:59 hajny Exp $ + **************************************************************************** + + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2002 by Free Pascal development team + + Free Pascal - EMX runtime library + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +****************************************************************************} + +unit {$ifdef VER1_0}sysemx{$else}System{$endif}; + +interface + +{Link the startup code.} +{$ifdef VER1_0} + {$l prt1.oo2} +{$else} + {$l prt1.o} +{$endif} + +{$I systemh.inc} + +const + LineEnding = #13#10; +{ LFNSupport is defined separately below!!! } + DirectorySeparator = '\'; + DriveSeparator = ':'; + PathSeparator = ';'; +{ FileNameCaseSensitive is defined separately below!!! } + maxExitCode = 255; + +type Tos=(osDOS,osOS2,osDPMI); + +var os_mode:Tos; + first_meg:pointer; + +type TByteArray = array [0..$ffff] of byte; + PByteArray = ^TByteArray; + + TSysThreadIB = record + TID, + Priority, + Version: cardinal; + MCCount, + MCForceFlag: word; + end; + PSysThreadIB = ^TSysThreadIB; + + TThreadInfoBlock = record + PExChain, + Stack, + StackLimit: pointer; + TIB2: PSysThreadIB; + Version, + Ordinal: cardinal; + end; + PThreadInfoBlock = ^TThreadInfoBlock; + PPThreadInfoBlock = ^PThreadInfoBlock; + + TProcessInfoBlock = record + PID, + ParentPid, + Handle: cardinal; + Cmd, + Env: PByteArray; + Status, + ProcType: cardinal; + end; + PProcessInfoBlock = ^TProcessInfoBlock; + PPProcessInfoBlock = ^PProcessInfoBlock; + +const UnusedHandle=-1; + StdInputHandle=0; + StdOutputHandle=1; + StdErrorHandle=2; + + LFNSupport: boolean = true; + FileNameCaseSensitive: boolean = false; + CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *) + + sLineBreak = LineEnding; + DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF; + +var +{ C-compatible arguments and environment } + argc : longint;external name '_argc'; + argv : ppchar;external name '_argv'; + envp : ppchar;external name '_environ'; + EnvC: cardinal; external name '_envc'; + +(* Pointer to the block of environment variables - used e.g. in unit Dos. *) + Environment: PChar; + +var +(* Type / run mode of the current process: *) +(* 0 .. full screen OS/2 session *) +(* 1 .. DOS session *) +(* 2 .. VIO windowable OS/2 session *) +(* 3 .. Presentation Manager OS/2 session *) +(* 4 .. detached (background) OS/2 process *) + ApplicationType: cardinal; + + +procedure SetDefaultOS2FileType (FType: ShortString); + +procedure SetDefaultOS2Creator (Creator: ShortString); + + + +implementation + +{$I system.inc} + +var + heap_base: pointer; external name '__heap_base'; + heap_brk: pointer; external name '__heap_brk'; + heap_end: pointer; external name '__heap_end'; + +(* Maximum heap size - only used if heap is allocated as continuous block. *) +{$IFDEF CONTHEAP} + BrkLimit: cardinal; +{$ENDIF CONTHEAP} + + +{**************************************************************************** + + Miscellaneous related routines. + +****************************************************************************} + +{$asmmode intel} +procedure system_exit; assembler; +asm + mov ah, 04ch + mov al, byte ptr exitcode + call syscall +end {['EAX']}; + +{$ASMMODE ATT} + +function paramcount:longint;assembler; + +asm + movl argc,%eax + decl %eax +end {['EAX']}; + + function args:pointer;assembler; + + asm + movl argv,%eax +end {['EAX']}; + + +function paramstr(l:longint):string; + +var p:^Pchar; + +begin + { There seems to be a problem with EMX for DOS when trying to } + { access paramstr(0), and to avoid problems between DOS and } + { OS/2 they have been separated. } + if os_Mode = OsOs2 then + begin + if L = 0 then + begin + GetMem (P, 260); + p[0] := #0; { in case of error, initialize to empty string } +{$ASMMODE INTEL} + asm + mov edx, P + mov ecx, 260 + mov eax, 7F33h + call syscall { error handle already with empty string } + end ['eax', 'ecx', 'edx']; + ParamStr := StrPas (PChar (P)); + FreeMem (P, 260); + end + else + if (l>0) and (l<=paramcount) then + begin + p:=args; + paramstr:=strpas(p[l]); + end + else paramstr:=''; + end + else + begin + p:=args; + paramstr:=strpas(p[l]); + end; +end; + + +procedure randomize; assembler; +asm + mov ah, 2Ch + call syscall + mov word ptr [randseed], cx + mov word ptr [randseed + 2], dx +end {['eax', 'ecx', 'edx']}; + +{$ASMMODE ATT} + + +{***************************************************************************** + + System unit initialization. + +****************************************************************************} + +{**************************************************************************** + Error Message writing using messageboxes +****************************************************************************} + +type + TWinMessageBox = function (Parent, Owner: cardinal; + BoxText, BoxTitle: PChar; Identity, Style: cardinal): cardinal; cdecl; + TWinInitialize = function (Options: cardinal): cardinal; cdecl; + TWinCreateMsgQueue = function (Handle: cardinal; cmsg: longint): cardinal; + cdecl; + +const + ErrorBufferLength = 1024; + mb_OK = $0000; + mb_Error = $0040; + mb_Moveable = $4000; + MBStyle = mb_OK or mb_Error or mb_Moveable; + WinInitialize: TWinInitialize = nil; + WinCreateMsgQueue: TWinCreateMsgQueue = nil; + WinMessageBox: TWinMessageBox = nil; + EnvSize: cardinal = 0; + +var + ErrorBuf: array [0..ErrorBufferLength] of char; + ErrorLen: longint; + PMWinHandle: cardinal; + +function ErrorWrite (var F: TextRec): integer; +{ + An error message should always end with #13#10#13#10 +} +var + P: PChar; + I: longint; +begin + if F.BufPos > 0 then + begin + if F.BufPos + ErrorLen > ErrorBufferLength then + I := ErrorBufferLength - ErrorLen + else + I := F.BufPos; + Move (F.BufPtr^, ErrorBuf [ErrorLen], I); + Inc (ErrorLen, I); + ErrorBuf [ErrorLen] := #0; + end; + if ErrorLen > 3 then + begin + P := @ErrorBuf [ErrorLen]; + for I := 1 to 4 do + begin + Dec (P); + if not (P^ in [#10, #13]) then + break; + end; + end; + if ErrorLen = ErrorBufferLength then + I := 4; + if (I = 4) then + begin + WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle); + ErrorLen := 0; + end; + F.BufPos := 0; + ErrorWrite := 0; +end; + +function ErrorClose (var F: TextRec): integer; +begin + if ErrorLen > 0 then + begin + WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle); + ErrorLen := 0; + end; + ErrorLen := 0; + ErrorClose := 0; +end; + +function ErrorOpen (var F: TextRec): integer; +begin + TextRec(F).InOutFunc := @ErrorWrite; + TextRec(F).FlushFunc := @ErrorWrite; + TextRec(F).CloseFunc := @ErrorClose; + ErrorOpen := 0; +end; + + +procedure AssignError (var T: Text); +begin + Assign (T, ''); + TextRec (T).OpenFunc := @ErrorOpen; + Rewrite (T); +end; + + +procedure DosEnvInit; +var + Q: PPChar; + I: cardinal; +begin +(* It's a hack, in fact - DOS stores the environment the same way as OS/2 does, + but I don't know how to find Program Segment Prefix and thus the environment + address under EMX, so I'm recreating this structure using EnvP pointer. *) +{$ASMMODE INTEL} + asm + cld + mov ecx, EnvC + mov esi, EnvP + xor eax, eax + xor edx, edx +@L1: + xchg eax, edx + push ecx + mov ecx, -1 + mov edi, [esi] + repne + scasb + neg ecx + dec ecx + xchg eax, edx + add eax, ecx + pop ecx + dec ecx + jecxz @Stop + inc esi + inc esi + inc esi + inc esi + jmp @L1 +@Stop: + inc eax + mov EnvSize, eax + end ['eax','ecx','edx','esi','edi']; + Environment := GetMem (EnvSize); + asm + cld + mov ecx, EnvC + mov edx, EnvP + mov edi, Environment +@L2: + mov esi, [edx] +@Copying: + lodsb + stosb + or al, al + jnz @Copying + dec ecx + jecxz @Stop2 + inc edx + inc edx + inc edx + inc edx + jmp @L2 +@Stop2: + stosb + end ['eax','ecx','edx','esi','edi']; +end; + + +procedure SysInitStdIO; +begin + { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be + displayed in a messagebox } +(* + StdInputHandle := longint(GetStdHandle(cardinal(STD_INPUT_HANDLE))); + StdOutputHandle := longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE))); + StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE))); + + if not IsConsole then + begin + if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and + (DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0) + and + (DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0) + and + (DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue)) + = 0) + then + begin + WinInitialize (0); + WinCreateMsgQueue (0, 0); + end + else + HandleError (2); + AssignError (StdErr); + AssignError (StdOut); + Assign (Output, ''); + Assign (Input, ''); + end + else + begin +*) + OpenStdIO (Input, fmInput, StdInputHandle); + OpenStdIO (Output, fmOutput, StdOutputHandle); + OpenStdIO (ErrOutput, fmOutput, StdErrorHandle); + OpenStdIO (StdOut, fmOutput, StdOutputHandle); + OpenStdIO (StdErr, fmOutput, StdErrorHandle); +(* + end; +*) +end; + + +{$ifdef HASTHREADVAR} +threadvar +{$else HASTHREADVAR} +var +{$endif HASTHREADVAR} + DefaultCreator: ShortString; + DefaultFileType: ShortString; + + +procedure SetDefaultOS2FileType (FType: ShortString); +begin +{$WARNING Not implemented yet!} + DefaultFileType := FType; +end; + + +procedure SetDefaultOS2Creator (Creator: ShortString); +begin +{$WARNING Not implemented yet!} + DefaultCreator := Creator; +end; + + +function GetFileHandleCount: longint; +var L1: longint; + L2: cardinal; +begin + L1 := 0; (* Don't change the amount, just check. *) + if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50 + else GetFileHandleCount := L2; +end; + +var TIB: PThreadInfoBlock; + PIB: PProcessInfoBlock; + +const + FatalHeap: array [0..33] of char = 'FATAL: Cannot initialize heap!!'#13#10'$'; + +begin + IsLibrary := FALSE; + {Determine the operating system we are running on.} +{$ASMMODE INTEL} + asm + push ebx + mov os_mode, 0 + mov eax, 7F0Ah + call syscall + test bx, 512 {Bit 9 is OS/2 flag.} + setne byte ptr os_mode + test bx, 4096 + jz @noRSX + mov os_mode, 2 + @noRSX: + {Enable the brk area by initializing it with the initial heap size.} + mov eax, 7F01h + mov edx, heap_brk + add edx, heap_base + call syscall + cmp eax, -1 + jnz @heapok + lea edx, FatalHeap + mov eax, 900h + call syscall + pop ebx + push dword 204 + call HandleError + @heapok: +{$IFDEF CONTHEAP} +{ Find out brk limit } + mov eax, 7F02h + mov ecx, 3 + call syscall + jcxz @heaplimitknown + mov eax, 0 + @heaplimitknown: + mov BrkLimit, eax +{$ELSE CONTHEAP} +{ Change sbrk behaviour to allocate arbitrary (non-contiguous) memory blocks } + mov eax, 7F0Fh + mov ecx, 0Ch + mov edx, 8 + call syscall +{$ENDIF CONTHEAP} + pop ebx + end ['eax', 'ecx', 'edx']; + { in OS/2 this will always be nil, but in DOS mode } + { this can be changed. } + first_meg := nil; + {Now request, if we are running under DOS, + read-access to the first meg. of memory.} + if os_mode in [osDOS,osDPMI] then + asm + push ebx + mov eax, 7F13h + xor ebx, ebx + mov ecx, 0FFFh + xor edx, edx + call syscall + jc @endmem + mov first_meg, eax + @endmem: + pop ebx + end ['eax', 'ecx', 'edx'] + else + begin + (* Initialize the amount of file handles *) + FileHandleCount := GetFileHandleCount; + end; + {At 0.9.2, case for enumeration does not work.} + case os_mode of + osDOS: + begin + stackbottom:=pointer(heap_brk); {In DOS mode, heap_brk is + also the stack bottom.} + ApplicationType := 1; (* Running under DOS. *) + IsConsole := true; + ProcessID := 1; + ThreadID := 1; + end; + osOS2: + begin + DosGetInfoBlocks (@TIB, @PIB); + StackBottom := pointer (TIB^.Stack); + Environment := pointer (PIB^.Env); + ApplicationType := PIB^.ProcType; + ProcessID := PIB^.PID; + ThreadID := TIB^.TIB2^.TID; + IsConsole := ApplicationType <> 3; + end; + osDPMI: + begin + stackbottom:=nil; {Not sure how to get it, but seems to be + always zero.} + ApplicationType := 1; (* Running under DOS. *) + IsConsole := true; + ProcessID := 1; + ThreadID := 1; + end; + end; + exitproc:=nil; + + {Initialize the heap.} + initheap; + + { ... and exceptions } + SysInitExceptions; + + { ... and I/O } + SysInitStdIO; + + { no I/O-Error } + inoutres:=0; + + InitSystemThreads; + +{$ifdef HASVARIANT} + initvariantmanager; +{$endif HASVARIANT} + + if os_Mode in [osDOS,osDPMI] then + DosEnvInit; + +{$IFDEF DUMPGROW} + {$IFDEF CONTHEAP} + WriteLn ('Initial brk size is ', GetHeapSize); + WriteLn ('Brk limit is ', BrkLimit); + {$ENDIF CONTHEAP} +{$ENDIF DUMPGROW} +end. +{ + $Log: system.pas,v $ + Revision 1.35 2005/04/03 21:10:59 hajny + * EOF_CTRLZ conditional define replaced with CtrlZMarksEOF, #26 handling made more consistent (fix for bug 2453) + + Revision 1.34 2005/02/14 17:13:22 peter + * truncate log + + Revision 1.33 2005/02/06 16:57:18 peter + * threads for go32v2,os,emx,netware + +} |