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

* merging Carl's fixes from the fixes branch

Browse Source
This commit is contained in:
Tomas Hajny 2001-05-20 18:51:09 +00:00
parent afe7569a0c
commit db66b45c55
2 changed files with 232 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

331
rtl/os2/dos.pas
View File

@ -200,8 +200,8 @@ var i,p1:longint;
function CheckFile (FN: ShortString):boolean; assembler; function CheckFile (FN: ShortString):boolean; assembler;
asm asm
mov ax, 4300h mov ax, 4300h
mov edx, FN mov edx, FN { get pointer to string }
inc edx inc edx { avoid length byte }
call syscall call syscall
mov ax, 0 mov ax, 0
jc @LCFstop jc @LCFstop
@ -257,7 +257,7 @@ begin
asm asm
{Load handle} {Load handle}
movl f,%ebx movl f,%ebx
movw (%ebx),%bx movl (%ebx),%ebx
{Get date} {Get date}
movw $0x5700,%ax movw $0x5700,%ax
call syscall call syscall
@ -272,14 +272,14 @@ end;
procedure SetFTime (var F; Time: longint); procedure SetFTime (var F; Time: longint);
var FStat: PFileStatus0; var FStat: PFileStatus3;
RC: longint; RC: longint;
begin begin
if os_mode = osOS2 then if os_mode = osOS2 then
begin begin
New (FStat); New (FStat);
RC := DosQueryFileInfo (TextRec (F).Handle, ilStandard, FStat, RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, FStat,
SizeOf (FStat^)); SizeOf (FStat^));
if RC = 0 then if RC = 0 then
begin begin
@ -287,16 +287,19 @@ begin
FStat^.DateLastWrite := Hi (Time); FStat^.DateLastWrite := Hi (Time);
FStat^.TimeLastAccess := Lo (Time); FStat^.TimeLastAccess := Lo (Time);
FStat^.TimeLastWrite := Lo (Time); FStat^.TimeLastWrite := Lo (Time);
RC := DosSetFileInfo (TextRec (F).Handle, ilStandard, RC := DosSetFileInfo (FileRec (F).Handle, ilStandard,
FStat, SizeOf (FStat^)); FStat, SizeOf (FStat^));
end; end;
DosError := integer(RC);
Dispose (FStat); Dispose (FStat);
end end
else else
asm asm
{Load handle} {Load handle}
movl f,%ebx movl f,%ebx
movw (%ebx),%bx movw (%ebx),%ebx
movl time,%ecx movl time,%ecx
shldl $16,%ecx,%edx shldl $16,%ecx,%edx
{Set date} {Set date}
@ -312,13 +315,16 @@ procedure msdos(var regs:registers);
{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
begin begin
if os_mode in [osDPMI,osDOS] then
intr($21,regs); intr($21,regs);
end; end;
procedure intr(intno:byte;var regs:registers); assembler; procedure intr(intno:byte;var regs:registers);
{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
begin
if os_mode = osos2 then exit;
asm asm
jmp .Lstart jmp .Lstart
{ .data} { .data}
@ -330,7 +336,7 @@ asm
{ .text} { .text}
.Lstart: .Lstart:
movl intno,%eax movb intno,%al
movb %al,.Lint86_vec movb %al,.Lint86_vec
{ {
@ -378,13 +384,14 @@ asm
movl %ebx,32(%eax) movl %ebx,32(%eax)
{FS and GS too} {FS and GS too}
end; end;
end;
procedure exec(const path:pathstr;const comline:comstr); procedure exec(const path:pathstr;const comline:comstr);
{Execute a program.} {Execute a program.}
begin begin
dosexitcode:=exec(path,execrunflags(ExecFlags),efdefault,comline); dosexitcode:=word(exec(path,execrunflags(ExecFlags),efdefault,comline));
end; end;
function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags; function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
@ -397,40 +404,47 @@ function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
type bytearray=array[0..8191] of byte; type bytearray=array[0..8191] of byte;
Pbytearray=^bytearray; Pbytearray=^bytearray;
execstruc=record execstruc=packed record
argofs,envofs,nameofs:pointer; argofs : pointer; { pointer to arguments (offset) }
argseg,envseg,nameseg:word; envofs : pointer; { pointer to environment (offset) }
numarg,sizearg, nameofs: pointer; { pointer to file name (offset) }
numenv,sizeenv:word; argseg : word; { pointer to arguments (selector) }
mode1,mode2:byte; envseg : word; { pointer to environment (selector}
nameseg: word; { pointer to file name (selector) }
numarg : word; { number of arguments }
sizearg : word; { size of arguments }
numenv : word; { number of env strings }
sizeenv:word; { size of environment }
mode1,mode2:byte; { mode byte }
end; end;
var args:Pbytearray; var args:Pbytearray;
env:Pbytearray; env:Pbytearray;
i,j:word; i,argsize:word;
es:execstruc; es:execstruc;
esadr:pointer; esadr:pointer;
d:dirstr; d:dirstr;
n:namestr; n:namestr;
e:extstr; e:extstr;
p : ppchar;
j : integer;
begin begin
getmem(args,512); getmem(args,512);
getmem(env,8192); GetMem(env, envc*sizeof(pchar)+16384);
j:=1;
{Now setup the arguments. The first argument should be the program {Now setup the arguments. The first argument should be the program
name without directory and extension.} name without directory and extension.}
fsplit(path,d,n,e); fsplit(path,d,n,e);
es.numarg:=1; es.numarg:=1;
args^[0]:=$80; args^[0]:=$80;
argsize:=1;
for i:=1 to length(n) do for i:=1 to length(n) do
begin begin
args^[j]:=byte(n[i]); args^[argsize]:=byte(n[i]);
inc(j); inc(argsize);
end; end;
args^[j]:=0; args^[argsize]:=0;
inc(j); inc(argsize);
{Now do the real arguments.} {Now do the real arguments.}
i:=1; i:=1;
while i<=length(comline) do while i<=length(comline) do
@ -439,21 +453,21 @@ begin
begin begin
{Commandline argument found. Copy it.} {Commandline argument found. Copy it.}
inc(es.numarg); inc(es.numarg);
args^[j]:=$80; args^[argsize]:=$80;
inc(j); inc(argsize);
while (i<=length(comline)) and (comline[i]<>' ') do while (i<=length(comline)) and (comline[i]<>' ') do
begin begin
args^[j]:=byte(comline[i]); args^[argsize]:=byte(comline[i]);
inc(j); inc(argsize);
inc(i); inc(i);
end; end;
args^[j]:=0; args^[argsize]:=0;
inc(j); inc(argsize);
end; end;
inc(i); inc(i);
end; end;
args^[j]:=0; args^[argsize]:=0;
inc(j); inc(argsize);
{Commandline ready, now build the environment. {Commandline ready, now build the environment.
@ -484,21 +498,23 @@ begin
{Environment ready, now set-up exec structure.} {Environment ready, now set-up exec structure.}
es.argofs:=args; es.argofs:=args;
es.envofs:=env; es.envofs:=env;
asm es.numenv:=envc;
leal path,%esi { set an error - path is too long }
lodsb { since we must add a zero to the }
movzbl %al,%eax { end. }
addl %eax,%esi if length(path) > 254 then
movb $0,(%esi) begin
end; exec := 8;
exit;
end;
path[length(path)+1] := #0;
es.nameofs:=pointer(longint(@path)+1); es.nameofs:=pointer(longint(@path)+1);
asm asm
movw %ss,es.argseg movw %ss,es.argseg
movw %ss,es.envseg movw %ss,es.envseg
movw %ss,es.nameseg movw %ss,es.nameseg
end; end;
es.sizearg:=j; es.sizearg:=argsize;
es.numenv:=0;
{Typecasting of sets in FPC is a bit hard.} {Typecasting of sets in FPC is a bit hard.}
es.mode1:=byte(runflags); es.mode1:=byte(runflags);
es.mode2:=byte(winflags); es.mode2:=byte(winflags);
@ -506,9 +522,9 @@ begin
{Now exec the program.} {Now exec the program.}
asm asm
leal es,%edx leal es,%edx
mov $0x7f06,%ax movw $0x7f06,%ax
call syscall call syscall
xorl %edi,%edi movl $0,%edi
jnc .Lexprg1 jnc .Lexprg1
xchgl %eax,%edi xchgl %eax,%edi
xorl %eax,%eax xorl %eax,%eax
@ -519,7 +535,7 @@ begin
end; end;
freemem(args,512); freemem(args,512);
freemem(env,8192); FreeMem(env, envc*sizeof(pchar)+16384);
{Phew! That's it. This was the most sophisticated procedure to call {Phew! That's it. This was the most sophisticated procedure to call
a system function I ever wrote!} a system function I ever wrote!}
end; end;
@ -562,8 +578,8 @@ begin
begin begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Year := Year; DT.Year := Year;
DT.Month := Month; DT.Month := byte (Month);
DT.Day := Day; DT.Day := byte (Day);
DosSetDateTime (DT); DosSetDateTime (DT);
end end
else else
@ -571,7 +587,7 @@ begin
mov cx, Year mov cx, Year
mov dh, byte ptr Month mov dh, byte ptr Month
mov dl, byte ptr Day mov dl, byte ptr Day
mov ah, $2b mov ah, 2Bh
call syscall call syscall
end; end;
end; end;
@ -604,10 +620,10 @@ begin
if os_mode = osOS2 then if os_mode = osOS2 then
begin begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Hour := Hour; DT.Hour := byte (Hour);
DT.Minute := Minute; DT.Minute := byte (Minute);
DT.Second := Second; DT.Second := byte (Second);
DT.Sec100 := Sec100; DT.Sec100 := byte (Sec100);
DosSetDateTime (DT); DosSetDateTime (DT);
end end
else else
@ -616,7 +632,7 @@ begin
mov cl, byte ptr Minute mov cl, byte ptr Minute
mov dh, byte ptr Second mov dh, byte ptr Second
mov dl, byte ptr Sec100 mov dl, byte ptr Sec100
mov ah, $2d mov ah, 2Dh
call syscall call syscall
end; end;
end; end;
@ -626,52 +642,59 @@ end;
procedure getcbreak(var breakvalue:boolean); procedure getcbreak(var breakvalue:boolean);
begin begin
{! Do not use in OS/2. Also not recommended in DOS. Use DosError := 0;
signal handling instead.} {! Do not use in OS/2. Also not recommended in DOS. Use
signal handling instead.
asm asm
movw $0x3300,%ax movw $0x3300,%ax
call syscall call syscall
movl 8(%ebp),%eax movl BreakValue,%eax
movb %dl,(%eax) movb %dl,(%eax)
end; end;
}
end; end;
procedure setcbreak(breakvalue:boolean); procedure setcbreak(breakvalue:boolean);
begin begin
{! Do not use in OS/2. Also not recommended in DOS. Use DosError := 0;
signal handling instead.} {! Do not use in OS/2. Also not recommended in DOS. Use
signal handling instead.
asm asm
movb 8(%ebp),%dl movb 8(%ebp),%dl
movw $0x3301,%ax movw $0x3301,%ax
call syscall call syscall
end; end;
}
end; end;
procedure getverify(var verify:boolean); procedure getverify(var verify:boolean);
begin begin
DosError := 0;
{! Do not use in OS/2.} {! Do not use in OS/2.}
asm if os_mode in [osDOS,osDPMI] then
movb $0x54,%ah asm
call syscall movb $0x54,%ah
movl 8(%ebp),%edi call syscall
stosb movl verify,%edi
end; stosb
end;
end; end;
procedure setverify(verify:boolean); procedure setverify(verify:boolean);
begin begin
{! Do not use in OS/2.} DosError := 0;
asm {! Do not use in OS/2!}
movb 8(%ebp),%al if os_mode in [osDOS,osDPMI] then
movb $0x2e,%ah asm
call syscall movb verify,%al
end; movb $0x2e,%ah
call syscall
end;
end; end;
function DiskFree (Drive: byte): int64; function DiskFree (Drive: byte): int64;
var FI: TFSinfo; var FI: TFSinfo;
@ -681,7 +704,7 @@ begin
if (os_mode = osDOS) or (os_mode = osDPMI) then if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.} {Function 36 is not supported in OS/2.}
asm asm
movb 8(%ebp),%dl Drive,%dl
movb $0x36,%ah movb $0x36,%ah
call syscall call syscall
cmpw $-1,%ax cmpw $-1,%ax
@ -690,6 +713,7 @@ begin
mulw %bx mulw %bx
shll $16,%edx shll $16,%edx
movw %ax,%dx movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax xchgl %edx,%eax
leave leave
ret ret
@ -719,7 +743,7 @@ begin
if (os_mode = osDOS) or (os_mode = osDPMI) then if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.} {Function 36 is not supported in OS/2.}
asm asm
movb 8(%ebp),%dl movb Drive,%dl
movb $0x36,%ah movb $0x36,%ah
call syscall call syscall
movw %dx,%bx movw %dx,%bx
@ -729,6 +753,7 @@ begin
mulw %bx mulw %bx
shll $16,%edx shll $16,%edx
movw %ax,%dx movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax xchgl %edx,%eax
leave leave
ret ret
@ -804,16 +829,15 @@ begin
end; end;
end; end;
procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
procedure _findfirst(path:pchar;attr:word;var f:searchrec); procedure _findfirst(path:pchar;attr:word;var f:searchrec);
begin begin
asm asm
movl 12(%esp),%edx movl path,%edx
movw 16(%esp),%cx movw attr,%cx
{No need to set DTA in EMX. Just give a pointer in ESI.} {No need to set DTA in EMX. Just give a pointer in ESI.}
movl 18(%ebp),%esi movl f,%esi
movb $0x4e,%ah movb $0x4e,%ah
call syscall call syscall
jnc .LFF jnc .LFF
@ -822,6 +846,10 @@ procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
end; end;
end; end;
procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
var path0: array[0..255] of char; var path0: array[0..255] of char;
Count: longint; Count: longint;
@ -844,14 +872,11 @@ begin
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
procedure FindNext (var F: SearchRec);
var Count: longint;
procedure _findnext(var f : searchrec); procedure _findnext(var f : searchrec);
begin begin
asm asm
movl 12(%ebp),%esi movl f,%esi
movb $0x4f,%ah movb $0x4f,%ah
call syscall call syscall
jnc .LFN jnc .LFN
@ -860,6 +885,11 @@ var Count: longint;
end; end;
end; end;
procedure FindNext (var F: SearchRec);
var Count: longint;
begin begin
{No error} {No error}
DosError := 0; DosError := 0;
@ -883,9 +913,7 @@ begin
end; end;
procedure swapvectors; procedure swapvectors;
{For TP compatibility, this exists.} {For TP compatibility, this exists.}
begin begin
end; end;
@ -898,16 +926,13 @@ asm
end ['EAX']; end ['EAX'];
function envcount:longint;assembler; function envcount:longint;assembler;
var hp : ppchar;
asm asm
movl envc,%eax movl envc,%eax
end ['EAX']; end ['EAX'];
function envstr(index : longint) : string; function envstr(index : longint) : string;
var hp:PPchar; var hp:Pchar;
begin begin
if (index<=0) or (index>envcount) then if (index<=0) or (index>envcount) then
@ -915,8 +940,8 @@ begin
envstr:=''; envstr:='';
exit; exit;
end; end;
hp:=PPchar(cardinal(envs)+4*(index-1)); hp:=envs[index-1];
envstr:=strpas(hp^); envstr:=strpas(hp);
end; end;
function getenv(const envvar : string) : string; function getenv(const envvar : string) : string;
@ -1030,37 +1055,133 @@ begin
d.year:=time+1980; d.year:=time+1980;
end; end;
procedure getfattr(var f;var attr : word);assembler; procedure getfattr(var f;var attr : word);
{ Under EMX, this routine requires }
{ the expanded path specification }
{ otherwise it will not function }
{ properly (CEC) }
var
path: pathstr;
buffer:array[0..255] of char;
begin
DosError := 0;
path:='';
path := StrPas(filerec(f).Name);
{ Takes care of slash and backslash support }
path:=FExPand(path);
move(path[1],buffer,length(path));
buffer[length(path)]:=#0;
asm asm
movw $0x4300,%ax movw $0x4300,%ax
movl f,%edx leal buffer,%edx
{addl $filerec.name,%edx Doesn't work!!}
addl $60,%edx
call syscall call syscall
jnc .Lnoerror { is there an error ? }
movw %ax,doserror
.Lnoerror:
movl attr,%ebx movl attr,%ebx
movw %cx,(%ebx) movw %cx,(%ebx)
xorb %ah,%ah end;
movw %ax,doserror
end; end;
procedure setfattr(var f;attr : word);assembler; procedure setfattr(var f;attr : word);
{ Under EMX, this routine requires }
{ the expanded path specification }
{ otherwise it will not function }
{ properly (CEC) }
var
path: pathstr;
buffer:array[0..255] of char;
begin
path:='';
DosError := 0;
path := StrPas(filerec(f).Name);
{ Takes care of slash and backslash support }
path:=FExPand(path);
move(path[1],buffer,length(path));
buffer[length(path)]:=#0;
asm asm
movw $0x4301,%ax movw $0x4301,%ax
movl f,%edx leal buffer,%edx
{addl $filerec.name,%edx Doesn't work!!} movw attr,%cx
addl $60,%edx call syscall
movw attr,%cx jnc .Lnoerror
call syscall movw %ax,doserror
xorb %ah,%ah .Lnoerror:
movw %ax,doserror end;
end; end;
procedure InitEnvironment;
var
cnt : integer;
ptr : pchar;
base : pchar;
i: integer;
tib : pprocessinfoblock;
begin
{ We need to setup the environment }
{ only in the case of OS/2 }
{ otherwise everything is in the stack }
if os_Mode in [OsDOS,osDPMI] then
exit;
cnt := 0;
{ count number of environment pointers }
dosgetinfoblocks(nil,@tib);
ptr := pchar(tib^.env);
{ stringz,stringz...,#0 }
i := 0;
repeat
repeat
(inc(i));
until (ptr[i] = #0);
inc(i);
{ here, it may be a double null, end of environment }
if ptr[i] <> #0 then
inc(cnt);
until (ptr[i] = #0);
{ save environment count }
envc := cnt;
{ got count of environment strings }
GetMem(envp, cnt*sizeof(pchar)+16384);
cnt := 0;
ptr := pchar(tib^.env);
i:=0;
repeat
envp[cnt] := ptr;
Inc(cnt);
{ go to next string ... }
repeat
inc(ptr);
until (ptr^ = #0);
inc(ptr);
until ptr^ = #0;
envp[cnt] := #0;
end;
procedure DoneEnvironment;
begin
{ it is allocated on the stack for DOS/DPMI }
if os_mode = osOs2 then
FreeMem(envp, envc*sizeof(pchar)+16384);
end;
var
oldexit : pointer;
begin
oldexit:=exitproc;
exitproc:=@doneenvironment;
InitEnvironment;
end. end.
{ {
$Log$ $Log$
Revision 1.10 2001-04-10 18:49:40 hajny Revision 1.11 2001-05-20 18:55:48 hajny
* merging Carl's fixes from the fixes branch
Revision 1.10 2001/04/10 18:49:40 hajny
* better check for FindClose * better check for FindClose
Revision 1.9 2001/03/11 18:58:42 hajny Revision 1.9 2001/03/11 18:58:42 hajny

11
rtl/os2/prt1.as
View File

@ -16,20 +16,21 @@
__entry1: __entry1:
popl %esi popl %esi
cld
xorl %ebp, %ebp xorl %ebp, %ebp
leal (%esp), %edi leal (%esp), %edi /* argv[] */
movl %edi,_environ movl %edi,_environ
call L_ptr_tbl call L_ptr_tbl
mov %ecx,_envc movl %ecx,_envc
mov %edi,_argv movl %edi,_argv
call L_ptr_tbl call L_ptr_tbl
mov %ecx,_argc movl %ecx,_argc
jmp *%esi jmp *%esi
L_ptr_tbl: L_ptr_tbl:
xorl %eax, %eax xorl %eax, %eax
movl $-1, %ecx movl $-1, %ecx
1: incl %ecx 1: incl %ecx
scasl scasl
jne 1b jne 1b
ret ret