paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 12:49:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* FExpand without IOResult change, remaining direct asm removed

Browse Source
This commit is contained in:
Tomas Hajny 2001-03-10 09:57:51 +00:00
parent d1d1c8b0b2
commit c83475a6ca
5 changed files with 147 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
rtl/go32v1/dos.pp
View File

@ -539,100 +539,18 @@ begin
end;
function fexpand(const path : pathstr) : pathstr;
var
s,pa : pathstr;
i,j : longint;
begin
getdir(0,s);
if LFNSupport then
begin
pa:=path;
{ Always uppercase driveletter }
if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['a'..'z']) then
pa[1]:=CHR(ORD(Pa[1])-32);
end
else
pa:=upcase(path);
{ allow slash as backslash }
for i:=1 to length(pa) do
if pa[i]='/' then
pa[i]:='\';
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z']) then
begin
{ we must get the right directory }
getdir(ord(pa[1])-ord('A')+1,s);
if (ord(pa[0])>2) and (pa[3]<>'\') then
if pa[1]=s[1] then
begin
{ remove ending slash if it already exists }
if s[length(s)]='\' then
dec(s[0]);
pa:=s+'\'+copy (pa,3,length(pa));
end
else
pa:=pa[1]+':\'+copy (pa,3,length(pa))
end
else
if pa[1]='\' then
pa:=s[1]+':'+pa
else if s[0]=#3 then
pa:=s+pa
else
pa:=s+'\'+pa;
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
if length(pa) = 2 then
begin
getdir(byte(pa[1])-64,s);
pa := s;
end;
{$I fexpand.inc}
{First remove all references to '\.\'}
while pos ('\.\',pa)<>0 do
delete (pa,pos('\.\',pa),2);
{Now remove also all references to '\..\' + of course previous dirs..}
repeat
i:=pos('\..\',pa);
if i<>0 then
begin
j:=i-1;
while (j>1) and (pa[j]<>'\') do
dec (j);
if pa[j+1] = ':' then j := 3;
delete (pa,j,i-j+3);
end;
until i=0;
{ Turbo Pascal gets rid of a \.. at the end of the path }
{ Now remove also any reference to '\..' at end of line
+ of course previous dir.. }
i:=pos('\..',pa);
if i<>0 then
begin
if i = length(pa) - 2 then
begin
j:=i-1;
while (j>1) and (pa[j]<>'\') do
dec (j);
delete (pa,j,i-j+3);
end;
pa := pa + '\';
end;
{ Remove End . and \}
if (length(pa)>0) and (pa[length(pa)]='.') then
dec(byte(pa[0]));
{ if only the drive + a '\' is left then the '\' should be left to prevtn the program
accessing the current directory on the drive rather than the root!}
{ if the last char of path = '\' then leave it in as this is what TP does! }
if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
dec(byte(pa[0]));
{ if only a drive is given in path then there should be a '\' at the
end of the string given back }
if length(pa) = 2 then pa := pa + '\';
fexpand:=pa;
end;
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
Function FSearch(path: pathstr; dirlist: string): pathstr;
@ -791,7 +709,10 @@ End;
end.
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
Revision 1.3 2001-03-10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.2 2000/07/13 11:33:38 michael
+ removed logs
}

22
rtl/go32v1/system.pp
View File

@ -532,21 +532,27 @@ begin
end;
procedure getdir(drivenr : byte;var dir : shortstring);
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
[public, alias: 'FPC_GETDIRIO'];
var
temp : array[0..255] of char;
sof : pchar;
i : byte;
IOR: word;
begin
sof:=pchar(@dir[4]);
{ dir[1..3] will contain '[drivenr]:\', but is not supplied by DOS,
so we let dos string start at dir[4]
Get dir from drivenr : 0=default, 1=A etc }
IOR := 0;
asm
movb drivenr,%dl
movl sof,%esi
mov $0x47,%ah
int $0x21
jnc .LGetDir
movw %ax, IOR
.LGetDir:
end;
{ Now Dir should be filled with directory in ASCIIZ starting from dir[4] }
dir[0]:=#3;
@ -563,7 +569,6 @@ begin
inc(i);
end;
{ upcase the string }
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(65+drivenr-1)
else
@ -578,6 +583,14 @@ begin
end;
dir[1]:=chr(i);
end;
dir:=upcase(dir);
GetDirIO := IOR;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{*****************************************************************************
@ -615,7 +628,10 @@ Begin
End.
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
Revision 1.3 2001-03-10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.2 2000/07/13 11:33:38 michael
+ removed logs
}

135
rtl/inc/fexpand.inc
View File

@ -1,32 +1,51 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1997-2000 by the Free Pascal development team
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.
**********************************************************************}
{****************************************************************************
A platform independent FExpand implementation
****************************************************************************}
function GetDirIO (DriveNr: byte; var Dir: OpenString): word;
[external name 'FPC_GETDIRIO'];
(* GetDirIO is supposed to return the root of the given drive *)
(* in case of an error for compatibility of FExpand with TP/BP. *)
(* Dir must be specified as OpenString since System has $P+. *)
function FExpand (const Path: PathStr): PathStr;
(* LFNSupport boolean constant, variable or function must be declared for all
the platforms, at least locally in the Dos unit implementation part.
In addition, FEXPAND_UNC, FEXPAND_DRIVES, FEXPAND_GETENV_PCHAR
and FEXPAND_TILDE conditionals might be defined to specify FExpand
In addition, FPC_FEXPAND_UNC, FPC_FEXPAND_DRIVES, FPC_FEXPAND_GETENV_PCHAR
and FPC_FEXPAND_TILDE conditionals might be defined to specify FExpand
behaviour. Only forward slashes are supported if UNIX conditional
is defined, both forward and backslashes otherwise.
*)
(* TODO: GetDir replacement function should appear here to remove
the incorrect setting of IOResult within FExpand.
*)
{
function get_current_drive:byte;assembler;
asm
movb $0x19,%ah
call syscall
end;
}
const
{$IFDEF UNIX}
DirSep = '/';
{$ELSE UNIX}
DirSep = '\';
{$ENDIF UNIX}
{$IFDEF FEXPAND_DRIVES}
{$IFDEF FPC_FEXPAND_DRIVES}
PathStart = 3;
{$ELSE FEXPAND_DRIVES}
{$ELSE FPC_FEXPAND_DRIVES}
PathStart = 1;
{$ENDIF FEXPAND_DRIVES}
{$ENDIF FPC_FEXPAND_DRIVES}
var S, Pa: PathStr;
I, J: longint;
@ -42,15 +61,16 @@ begin
if Pa [I] = '/' then
Pa [I] := DirSep;
{$ENDIF}
{$IFDEF FEXPAND_TILDE}
{$IFDEF FPC_FEXPAND_TILDE}
{Replace ~/ with $HOME}
if (Length (Pa) > 1) and (Pa [1] ='~') and (Pa [2] = DirSep) then
if (Length (Pa) >= 1) and (Pa [1] ='~') and
((Pa [2] = DirSep) or (Length (Pa) = 1)) then
begin
{$IFDEF FEXPAND_GETENV_PCHAR}
{$IFDEF FPC_FEXPAND_GETENV_PCHAR}
S := StrPas (GetEnv ('HOME'));
{$ELSE FEXPAND_GETENV_PCHAR}
{$ELSE FPC_FEXPAND_GETENV_PCHAR}
S := GetEnv ('HOME');
{$ENDIF FEXPAND_GETENV_PCHAR}
{$ENDIF FPC_FEXPAND_GETENV_PCHAR}
if (S = '') or (Length (S) = 1) and (S [1] = DirSep) then
Delete (Pa, 1, 1)
else
@ -59,27 +79,15 @@ begin
else
Pa := S + Copy (Pa, 2, Pred (Length (Pa)));
end;
{$ENDIF FEXPAND_TILDE}
{$ENDIF FPC_FEXPAND_TILDE}
if (Length (Pa) > 1) and (Pa [1] in ['A'..'Z', 'a'..'z']) and
(Pa [2] = ':') then
begin
{$IFDEF FEXPAND_DRIVES}
{$IFDEF FPC_FEXPAND_DRIVES}
{ Always uppercase driveletter }
if (Pa [1] in ['a'..'z']) then
Pa [1] := Chr (Ord (Pa [1]) and not ($20));
{We must get the right directory (should be changed to avoid
touching IOResult)}
{$IFOPT I+}
{$DEFINE FEXPAND_WAS_I}
{$I-}
{$ENDIF}
I := IOResult;
GetDir (Ord (Pa [1]) - Ord ('A') + 1, S);
I := IOResult;
{$IFDEF FEXPAND_WAS_I}
{$I+}
{$UNDEF FEXPAND_WAS_I}
{$ENDIF FEXPAND_WAS_I}
if GetDirIO (Ord (Pa [1]) - Ord ('A') + 1, S) = 0 then ;
case Length (Pa) of
2: Pa := S;
else
@ -96,35 +104,25 @@ begin
end;
end
else
{$ELSE FEXPAND_DRIVES}
{$ELSE FPC_FEXPAND_DRIVES}
Delete (Path, 1, 2);
Delete (Pa, 1, 2);
end;
{$ENDIF FEXPAND_DRIVES}
{$ENDIF FPC_FEXPAND_DRIVES}
begin
{$IFOPT I+}
{$DEFINE FEXPAND_WAS_I}
{$I-}
{$ENDIF}
I := IOResult;
GetDir (0, S);
I := IOResult;
{$IFDEF FEXPAND_WAS_I}
{$I+}
{$UNDEF FEXPAND_WAS_I}
{$ENDIF FEXPAND_WAS_I}
{$IFDEF FEXPAND_DRIVES}
if GetDirIO (0, S) = 0 then ;
{$IFDEF FPC_FEXPAND_DRIVES}
if (Length (Pa) > 0) and (Pa [1] = DirSep) then
begin
{$IFDEF FEXPAND_UNC}
{$IFDEF FPC_FEXPAND_UNC}
{ Do not touch Network drive names }
if not ((Length (Pa) > 1) and (Pa [2] = Pa [1])
and LFNSupport) then
{$ENDIF FEXPAND_UNC}
{$ENDIF FPC_FEXPAND_UNC}
Pa := S [1] + ':' + Pa
end
else
{$ENDIF FEXPAND_DRIVES}
{$ENDIF FPC_FEXPAND_DRIVES}
(* We already have a slash if root is the curent directory. *)
if Length (S) = PathStart then
Pa := S + Pa
@ -151,9 +149,9 @@ begin
while (J > 0) and (Pa [J] <> DirSep) do
Dec (J);
if (J = 0)
{$IFDEF FEXPAND_UNC}
{$IFDEF FPC_FEXPAND_UNC}
or (J = 1) and (I = 2)
{$ENDIF FEXPAND_UNC}
{$ENDIF FPC_FEXPAND_UNC}
then
Delete (Pa, Succ (I), 3)
else
@ -169,9 +167,9 @@ begin
while (J >= 1) and (Pa [J] <> DirSep) do
Dec (J);
if (J = 0)
{$IFDEF FEXPAND_UNC}
{$IFDEF FPC_FEXPAND_UNC}
or (J = 1) and (I = 2)
{$ENDIF FEXPAND_UNC}
{$ENDIF FPC_FEXPAND_UNC}
then
Delete (Pa, Succ (I), 2)
else
@ -180,14 +178,15 @@ begin
{Now remove also any reference to '\.' at the end of line}
I := Pos (DirSep + '.', Pa);
if (I <> 0) and (I = Pred (Length (Pa))) then
if (I = PathStart)
{$IFDEF FEXPAND_DRIVES}
and (Pa [2] = ':')
{$ENDIF FEXPAND_DRIVES}
{$IFDEF FEXPAND_UNC}
or (I = 2) and (Pa [1] = '\')
{$ENDIF FEXPAND_UNC}
then
{$IFDEF FPC_FEXPAND_DRIVES}
if (I = 3) and (Pa [2] = ':')
{$ELSE FPC_FEXPAND_DRIVES}
if (I = 1)
{$ENDIF FPC_FEXPAND_DRIVES}
{$IFDEF FPC_FEXPAND_UNC}
or (I = 2) and (Pa [1] = '\')
{$ENDIF FPC_FEXPAND_UNC}
then
Dec (Pa [0])
else
Delete (Pa, I, 2);
@ -198,3 +197,11 @@ begin
Dec (Pa [0]);
FExpand := Pa;
end;
{
$Log$
Revision 1.2 2001-03-10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
}

36
rtl/os2/dos.pas
View File

@ -182,6 +182,7 @@ uses DosCalls;
var LastSR: SearchRec;
envc: longint; external name '_envc';
EnvP: ppchar; external name '_environ';
type TBA = array [1..SizeOf (SearchRec)] of byte;
PBA = ^TBA;
@ -460,31 +461,27 @@ begin
Oh boy, I always had the opinion that executing a program under Dos
was a hard job!}
{$ASMMODE DIRECT}
asm
movl env,%edi {Setup destination pointer.}
movl _envc,%ecx {Load number of arguments in edx.}
movl _environ,%esi {Load env. strings.}
movl envc,%ecx {Load number of arguments in edx.}
movl envp,%esi {Load env. strings.}
xorl %edx,%edx {Count environment size.}
exa1:
.Lexa1:
lodsl {Load a Pchar.}
xchgl %eax,%ebx
exa2:
.Lexa2:
movb (%ebx),%al {Load a byte.}
incl %ebx {Point to next byte.}
stosb {Store it.}
incl %edx {Increase counter.}
cmpb $0,%al {Ready ?.}
jne exa2
loop exa1 {Next argument.}
jne .Lexa2
loop .Lexa1 {Next argument.}
stosb {Store an extra 0 to finish. (AL is now 0).}
incl %edx
movl %edx,(24)es {Store environment size.}
movw %dx,ES.SizeEnv {Store environment size.}
end;
{$ASMMODE ATT}
{Environment ready, now set-up exec structure.}
es.argofs:=args;
es.envofs:=env;
@ -988,17 +985,21 @@ begin
name:=path;
end;
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
const
LFNSupport = true;
{$I fexpand.inc}
{$UNDEF FEXPAND_DRIVES}
{$UNDEF FEXPAND_UNC}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
procedure packtime(var d:datetime;var time:longint);
@ -1066,7 +1067,10 @@ end;
end.
{
$Log$
Revision 1.7 2001-02-04 01:57:52 hajny
Revision 1.8 2001-03-10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.7 2001/02/04 01:57:52 hajny
* direct asm removing
Revision 1.6 2000/11/06 20:35:05 hajny

30
rtl/os2/system.pas
View File

@ -771,25 +771,32 @@ end;
{$ASMMODE ATT}
procedure getdir(drivenr : byte;var dir : shortstring);
function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
[public, alias: 'FPC_GETDIRIO'];
{Written by Michael Van Canneyt.}
var temp:array[0..255] of char;
sof:Pchar;
var sof:Pchar;
i:byte;
IOR: word;
begin
Dir [4] := #0;
{ Used in case the specified drive isn't available }
sof:=pchar(@dir[4]);
{ dir[1..3] will contain '[drivenr]:\', but is not }
{ supplied by DOS, so we let dos string start at }
{ dir[4] }
{ Get dir from drivenr : 0=default, 1=A etc... }
IOR := 0;
asm
movb drivenr,%dl
movl sof,%esi
mov $0x47,%ah
call syscall
jnc .LGetDir
movw %ax, IOR
.LGetDir:
end;
{ Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] }
@ -807,9 +814,8 @@ begin
inc(i);
end;
{ upcase the string (FPC function) }
if not (FileNameCaseSensitive) then dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=char(65+drivenr-1)
dir[1]:=chr(64+drivenr)
else
begin
{ We need to get the current drive from DOS function 19H }
@ -822,13 +828,21 @@ begin
end;
dir[1]:=char(i);
end;
if not (FileNameCaseSensitive) then dir:=upcase(dir);
GetDirIO := IOR;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{****************************************************************************
Thread Handling
*****************************************************************************}
const
@ -845,6 +859,7 @@ end;
{$I thread.inc}
{*****************************************************************************
System unit initialization.
****************************************************************************}
@ -949,7 +964,10 @@ begin
end.
{
$Log$
Revision 1.8 2001-02-20 21:31:12 peter
Revision 1.9 2001-03-10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.8 2001/02/20 21:31:12 peter
* chdir,mkdir,rmdir with empty string fixed
Revision 1.7 2001/02/04 01:57:52 hajny