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

* GetDir fixed

Browse Source
This commit is contained in:
Tomas Hajny 2001-03-21 21:08:20 +00:00
parent 4ac6b9a7ca
commit f041ede95b
6 changed files with 46 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
rtl/go32v1/system.pp
View File

@ -532,26 +532,23 @@ begin
end; end;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word; procedure GetDir (DriveNr: byte; var Dir: ShortString);
[public, alias: 'FPC_GETDIRIO'];
var var
temp : array[0..255] of char; temp : array[0..255] of char;
sof : pchar; sof : pchar;
i : byte; i : byte;
IOR: word;
begin begin
sof:=pchar(@dir[4]); sof:=pchar(@dir[4]);
{ dir[1..3] will contain '[drivenr]:\', but is not supplied by DOS, { dir[1..3] will contain '[drivenr]:\', but is not supplied by DOS,
so we let dos string start at dir[4] so we let dos string start at dir[4]
Get dir from drivenr : 0=default, 1=A etc } Get dir from drivenr : 0=default, 1=A etc }
IOR := 0;
asm asm
movb drivenr,%dl movb drivenr,%dl
movl sof,%esi movl sof,%esi
mov $0x47,%ah mov $0x47,%ah
int $0x21 int $0x21
jnc .LGetDir jnc .LGetDir
movw %ax, IOR movw %ax, InOutRes
.LGetDir: .LGetDir:
end; end;
{ Now Dir should be filled with directory in ASCIIZ starting from dir[4] } { Now Dir should be filled with directory in ASCIIZ starting from dir[4] }
@ -584,14 +581,8 @@ begin
dir[1]:=chr(i); dir[1]:=chr(i);
end; end;
dir:=upcase(dir); dir:=upcase(dir);
GetDirIO := IOR;
end; end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{***************************************************************************** {*****************************************************************************
System Dependent Exit code System Dependent Exit code
@ -628,7 +619,10 @@ Begin
End. End.
{ {
$Log$ $Log$
Revision 1.3 2001-03-10 09:57:51 hajny Revision 1.4 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.3 2001/03/10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed * FExpand without IOResult change, remaining direct asm removed
Revision 1.2 2000/07/13 11:33:38 michael Revision 1.2 2000/07/13 11:33:38 michael

18
rtl/go32v2/system.pp
View File

@ -1280,15 +1280,12 @@ begin
end; end;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word; procedure GetDir (DriveNr: byte; var Dir: ShortString);
[public, alias: 'FPC_GETDIRIO'];
var var
temp : array[0..255] of char; temp : array[0..255] of char;
i : longint; i : longint;
regs : trealregs; regs : trealregs;
IOR: word;
begin begin
IOR := 0;
regs.realedx:=drivenr; regs.realedx:=drivenr;
regs.realesi:=tb_offset; regs.realesi:=tb_offset;
regs.realds:=tb_segment; regs.realds:=tb_segment;
@ -1301,7 +1298,7 @@ begin
sysrealintr($21,regs); sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then if (regs.realflags and carryflag) <> 0 then
Begin Begin
IOR := lo(regs.realeax); GetInOutRes (lo(regs.realeax));
exit; exit;
end end
else else
@ -1334,12 +1331,6 @@ begin
end; end;
end; end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
GetInOutRes (GetDirIO (DriveNr, Dir));
end;
{***************************************************************************** {*****************************************************************************
SystemUnit Initialization SystemUnit Initialization
@ -1426,7 +1417,10 @@ Begin
End. End.
{ {
$Log$ $Log$
Revision 1.5 2001-03-16 20:09:58 hajny Revision 1.6 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.5 2001/03/16 20:09:58 hajny
* universal FExpand * universal FExpand
Revision 1.4 2001/02/20 21:31:12 peter Revision 1.4 2001/02/20 21:31:12 peter

17
rtl/inc/fexpand.inc
View File

@ -18,11 +18,19 @@
function GetDirIO (DriveNr: byte; var Dir: OpenString): word; function GetDirIO (DriveNr: byte; var Dir: OpenString): word;
[external name 'FPC_GETDIRIO'];
(* GetDirIO is supposed to return the root of the given drive *) (* GetDirIO is supposed to return the root of the given drive *)
(* in case of an error for compatibility of FExpand with TP/BP. *) (* in case of an error for compatibility of FExpand with TP/BP. *)
(* Dir must be specified as OpenString since System has $P+. *)
var
OldInOutRes: word;
begin
OldInOutRes := InOutRes;
InOutRes := 0;
GetDir (DriveNr, Dir);
GetDirIO := InOutRes;
InOutRes := OldInOutRes;
end;
function FExpand (const Path: PathStr): PathStr; function FExpand (const Path: PathStr): PathStr;
@ -199,7 +207,10 @@ end;
{ {
$Log$ $Log$
Revision 1.4 2001-03-19 21:09:30 hajny Revision 1.5 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.4 2001/03/19 21:09:30 hajny
* one more problem in the Unix part * one more problem in the Unix part
Revision 1.3 2001/03/19 21:05:42 hajny Revision 1.3 2001/03/19 21:05:42 hajny

19
rtl/os2/system.pas
View File

@ -771,14 +771,12 @@ end;
{$ASMMODE ATT} {$ASMMODE ATT}
function GetDirIO (DriveNr: byte; var Dir: ShortString): word; procedure GetDir (DriveNr: byte; var Dir: ShortString);
[public, alias: 'FPC_GETDIRIO'];
{Written by Michael Van Canneyt.} {Written by Michael Van Canneyt.}
var sof:Pchar; var sof:Pchar;
i:byte; i:byte;
IOR: word;
begin begin
Dir [4] := #0; Dir [4] := #0;
@ -788,14 +786,13 @@ begin
{ supplied by DOS, so we let dos string start at } { supplied by DOS, so we let dos string start at }
{ dir[4] } { dir[4] }
{ Get dir from drivenr : 0=default, 1=A etc... } { Get dir from drivenr : 0=default, 1=A etc... }
IOR := 0;
asm asm
movb drivenr,%dl movb drivenr,%dl
movl sof,%esi movl sof,%esi
mov $0x47,%ah mov $0x47,%ah
call syscall call syscall
jnc .LGetDir jnc .LGetDir
movw %ax, IOR movw %ax, InOutRes
.LGetDir: .LGetDir:
end; end;
{ Now Dir should be filled with directory in ASCIIZ, } { Now Dir should be filled with directory in ASCIIZ, }
@ -829,13 +826,6 @@ begin
dir[1]:=char(i); dir[1]:=char(i);
end; end;
if not (FileNameCaseSensitive) then dir:=upcase(dir); if not (FileNameCaseSensitive) then dir:=upcase(dir);
GetDirIO := IOR;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end; end;
@ -964,7 +954,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.9 2001-03-10 09:57:51 hajny Revision 1.10 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.9 2001/03/10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed * FExpand without IOResult change, remaining direct asm removed
Revision 1.8 2001/02/20 21:31:12 peter Revision 1.8 2001/02/20 21:31:12 peter

15
rtl/unix/sysunix.inc
View File

@ -482,8 +482,7 @@ Begin
End; End;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word; procedure GetDir (DriveNr: byte; var Dir: ShortString);
[public, alias: 'FPC_GETDIRIO'];
var var
thisdir : stat; thisdir : stat;
rootino, rootino,
@ -498,7 +497,6 @@ var
mountpoint,validdir : boolean; mountpoint,validdir : boolean;
predot : string[255]; predot : string[255];
begin begin
GetDirIO := 0;
drivenr:=0; drivenr:=0;
dir:=''; dir:='';
thedir:='/'#0; thedir:='/'#0;
@ -554,12 +552,6 @@ begin
dir:=thedir dir:=thedir
end; end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{***************************************************************************** {*****************************************************************************
SystemUnit Initialization SystemUnit Initialization
@ -754,7 +746,10 @@ End.
{ {
$Log$ $Log$
Revision 1.6 2001-03-16 20:09:58 hajny Revision 1.7 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.6 2001/03/16 20:09:58 hajny
* universal FExpand * universal FExpand
Revision 1.5 2001/02/20 21:31:12 peter Revision 1.5 2001/02/20 21:31:12 peter

23
rtl/win32/system.pp
View File

@ -640,23 +640,23 @@ begin
dirfn(TDirFnType(@SetCurrentDirectory),s); dirfn(TDirFnType(@SetCurrentDirectory),s);
end; end;
function GetDirIO (DriveNr: byte; var Dir: ShortString): word; procedure GetDir (DriveNr: byte; var Dir: ShortString);
[public, alias: 'FPC_GETDIRIO'];
const const
Drive:array[0..3]of char=(#0,':',#0,#0); Drive:array[0..3]of char=(#0,':',#0,#0);
var var
defaultdrive:boolean; defaultdrive:boolean;
DirBuf,SaveBuf:array[0..259] of Char; DirBuf,SaveBuf:array[0..259] of Char;
IOR: word;
begin begin
IOR := 0;
defaultdrive:=drivenr=0; defaultdrive:=drivenr=0;
if not defaultdrive then if not defaultdrive then
begin begin
byte(Drive[0]):=Drivenr+64; byte(Drive[0]):=Drivenr+64;
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf); GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
if SetCurrentDirectory(@Drive) <> 0 then if SetCurrentDirectory(@Drive) <> 0 then
IOR := word (GetLastError); begin
errno := word (GetLastError);
Errno2InoutRes;
end;
end; end;
GetCurrentDirectory(SizeOf(DirBuf),DirBuf); GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
if not defaultdrive then if not defaultdrive then
@ -664,14 +664,6 @@ begin
dir:=strpas(DirBuf); dir:=strpas(DirBuf);
if not FileNameCaseSensitive then if not FileNameCaseSensitive then
dir:=upcase(dir); dir:=upcase(dir);
GetDirIO := IOR;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
errno := GetDirIO (DriveNr, Dir);
Errno2InoutRes;
end; end;
@ -1438,7 +1430,10 @@ end.
{ {
$Log$ $Log$
Revision 1.7 2001-03-16 20:09:58 hajny Revision 1.8 2001-03-21 21:08:20 hajny
* GetDir fixed
Revision 1.7 2001/03/16 20:09:58 hajny
* universal FExpand * universal FExpand
Revision 1.6 2001/02/20 21:31:12 peter Revision 1.6 2001/02/20 21:31:12 peter