paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 10:45:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

* GetEnv correction, better PM support, ...

Browse Source
This commit is contained in:
Tomas Hajny 2002-12-07 19:17:13 +00:00
parent aea2fdff0e
commit ab27397399
2 changed files with 216 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
rtl/os2/dos.pas
View File

@ -943,58 +943,53 @@ begin
{$ASMMODE INTEL}
asm
cld
mov ecx, EnvC
mov edi, EnvP
mov edi, [edi]
mov edi, Environment
lea esi, _EnvVar
xor eax, eax
lodsb
@NewVar:
push ecx
push eax
push esi
mov ecx, -1
mov edx, edi
mov al, '='
cmp byte ptr [edi], 0
jz @Stop
push eax { eax contains length of searched variable name }
push esi { esi points to the beginning of the variable name }
mov ecx, -1 { our character ('=' - see below) _must_ be found }
mov edx, edi { pointer to beginning of variable name saved in edx }
mov al, '=' { searching until '=' (end of variable name) }
repne
scasb
neg ecx
dec ecx
dec ecx
pop esi
pop eax
push eax
scasb { scan until '=' not found }
neg ecx { what was the name length? }
dec ecx { corrected }
dec ecx { exclude the '=' character }
pop esi { restore pointer to beginning of variable name }
pop eax { restore length of searched variable name }
push eax { and save both of them again for later use }
push esi
cmp ecx, eax
jnz @NotEqual
xchg edx, edi
cmp ecx, eax { compare length of searched variable name with name }
jnz @NotEqual { ... of currently found variable, jump if different }
xchg edx, edi { pointer to current variable name restored in edi }
repe
cmpsb
xchg edx, edi
jz @Equal
cmpsb { compare till the end of variable name }
xchg edx, edi { pointer to beginning of variable contents in edi }
jz @Equal { finish if they're equal }
@NotEqual:
xor eax, eax
mov ecx, -1
xor eax, eax { look for 00h }
mov ecx, -1 { it _must_ be found }
repne
scasb
pop esi
pop eax
pop ecx
dec ecx
jecxz @Stop
jmp @NewVar
scasb { scan until found }
pop esi { restore pointer to beginning of variable name }
pop eax { restore length of searched variable name }
jmp @NewVar { ... or continue with new variable otherwise }
@Stop:
mov P, ecx
xor eax, eax
mov P, eax { Not found - return nil }
jmp @End
@Equal:
pop esi
pop esi { restore the stack position }
pop eax
pop ecx
mov P, edi
mov P, edi { place pointer to variable contents in P }
@End:
end;
GetEnv := StrPas (P);
end;
{$ASMMODE ATT}
procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
@ -1218,7 +1213,10 @@ begin
end.
{
$Log$
Revision 1.20 2002-11-18 19:51:00 hajny
Revision 1.21 2002-12-07 19:17:13 hajny
* GetEnv correction, better PM support, ...
Revision 1.20 2002/11/18 19:51:00 hajny
* another bunch of type corrections
Revision 1.19 2002/09/07 16:01:24 peter

198
rtl/os2/system.pas
View File

@ -109,6 +109,18 @@ var
argv : ppchar;external name '_argv';
envp : ppchar;external name '_environ';
(* 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;
implementation
{$I system.inc}
@ -117,6 +129,8 @@ 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}
@ -125,6 +139,14 @@ procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
PAPIB: PPProcessInfoBlock); cdecl;
external 'DOSCALLS' index 312;
function DosLoadModule (ObjName: PChar; ObjLen: cardinal; DLLName: PChar;
var Handle: cardinal): longint; cdecl;
external 'DOSCALLS' index 318;
function DosQueryProcAddr (Handle, Ordinal: cardinal; ProcName: PChar;
var Address: pointer): longint; cdecl;
external 'DOSCALLS' index 321;
function DosSetRelMaxFH (var ReqCount, CurMaxFH: longint): longint; cdecl;
external 'DOSCALLS' index 382;
@ -134,9 +156,9 @@ external 'DOSCALLS' index 255;
function DosSetDefaultDisk (DiskNum:longint): longint; cdecl;
external 'DOSCALLS' index 220;
{ This is not real prototype, but its close enough }
{ for us. (The 2nd parameter is acutally a pointer) }
{ to a structure. }
{ This is not real prototype, but is close enough }
{ for us (the 2nd parameter is actually a pointer }
{ to a structure). }
function DosCreateDir( Name : pchar; p : pointer): longint; cdecl;
external 'DOSCALLS' index 270;
@ -883,12 +905,136 @@ end;
****************************************************************************}
{****************************************************************************
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;
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 SysInitStdIO;
begin
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ 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 (StdOut, fmOutput, StdOutputHandle);
OpenStdIO (StdErr, fmOutput, StdErrorHandle);
end;
end;
@ -900,10 +1046,10 @@ begin
else GetFileHandleCount := L2;
end;
var tib:Pthreadinfoblock;
var TIB: PThreadInfoBlock;
PIB: PProcessInfoBlock;
begin
IsConsole := TRUE;
IsLibrary := FALSE;
{Determine the operating system we are running on.}
{$ASMMODE INTEL}
@ -971,16 +1117,31 @@ begin
{At 0.9.2, case for enumeration does not work.}
case os_mode of
osDOS:
stackbottom:=cardinal(heap_brk); {In DOS mode, heap_brk is also the
stack bottom.}
begin
stackbottom:=cardinal(heap_brk); {In DOS mode, heap_brk is
also the stack bottom.}
ApplicationType := 1; (* Running under DOS. *)
IsConsole := true;
(* Currently broken!!! *)
Environment := nil;
end;
osOS2:
begin
dosgetinfoblocks(@tib,nil);
stackbottom:=cardinal(tib^.stack);
DosGetInfoBlocks (@TIB, @PIB);
StackBottom := cardinal (TIB^.Stack);
Environment := pointer (PIB^.Env);
ApplicationType := PIB^.ProcType;
IsConsole := ApplicationType <> 3;
end;
osDPMI:
stackbottom:=0; {Not sure how to get it, but seems to be
always zero.}
begin
stackbottom:=0; {Not sure how to get it, but seems to be
always zero.}
ApplicationType := 1; (* Running under DOS. *)
IsConsole := true;
(* Currently broken!!! *)
Environment := nil;
end;
end;
exitproc:=nil;
@ -1009,8 +1170,11 @@ begin
end.
{
$Log$
Revision 1.27 2002-11-17 22:31:02 hajny
* type corrections (longing x cardinal)
Revision 1.28 2002-12-07 19:17:14 hajny
* GetEnv correction, better PM support, ...
Revision 1.27 2002/11/17 22:31:02 hajny
* type corrections (longint x cardinal)
Revision 1.26 2002/10/27 14:29:00 hajny
* heap management (hopefully) fixed