paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 00:09:17 +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; end;
function fexpand(const path : pathstr) : pathstr; (*
var function FExpand (const Path: PathStr): PathStr;
s,pa : pathstr; - declared in fexpand.inc
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]:='\';
if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z']) then {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
begin {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{ 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;
{ Turbo Pascal gives current dir on drive if only drive given as parameter! } {$I fexpand.inc}
if length(pa) = 2 then
begin
getdir(byte(pa[1])-64,s);
pa := s;
end;
{First remove all references to '\.\'} {$UNDEF FPC_FEXPAND_DRIVES}
while pos ('\.\',pa)<>0 do {$UNDEF FPC_FEXPAND_UNC}
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;
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
@ -791,7 +709,10 @@ End;
end. end.
{ {
$Log$ $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 + removed logs
} }

22
rtl/go32v1/system.pp
View File

@ -532,21 +532,27 @@ begin
end; end;
procedure getdir(drivenr : byte;var dir : shortstring); function GetDirIO (DriveNr: byte; var Dir: ShortString): word;
[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
movw %ax, IOR
.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] }
dir[0]:=#3; dir[0]:=#3;
@ -563,7 +569,6 @@ begin
inc(i); inc(i);
end; end;
{ upcase the string } { upcase the string }
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it } if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(65+drivenr-1) dir[1]:=chr(65+drivenr-1)
else else
@ -578,6 +583,14 @@ begin
end; end;
dir[1]:=chr(i); dir[1]:=chr(i);
end; end;
dir:=upcase(dir);
GetDirIO := IOR;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end; end;
{***************************************************************************** {*****************************************************************************
@ -615,7 +628,10 @@ Begin
End. End.
{ {
$Log$ $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 + 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 (* LFNSupport boolean constant, variable or function must be declared for all
the platforms, at least locally in the Dos unit implementation part. the platforms, at least locally in the Dos unit implementation part.
In addition, FEXPAND_UNC, FEXPAND_DRIVES, FEXPAND_GETENV_PCHAR In addition, FPC_FEXPAND_UNC, FPC_FEXPAND_DRIVES, FPC_FEXPAND_GETENV_PCHAR
and FEXPAND_TILDE conditionals might be defined to specify FExpand and FPC_FEXPAND_TILDE conditionals might be defined to specify FExpand
behaviour. Only forward slashes are supported if UNIX conditional behaviour. Only forward slashes are supported if UNIX conditional
is defined, both forward and backslashes otherwise. 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 const
{$IFDEF UNIX} {$IFDEF UNIX}
DirSep = '/'; DirSep = '/';
{$ELSE UNIX} {$ELSE UNIX}
DirSep = '\'; DirSep = '\';
{$ENDIF UNIX} {$ENDIF UNIX}
{$IFDEF FEXPAND_DRIVES} {$IFDEF FPC_FEXPAND_DRIVES}
PathStart = 3; PathStart = 3;
{$ELSE FEXPAND_DRIVES} {$ELSE FPC_FEXPAND_DRIVES}
PathStart = 1; PathStart = 1;
{$ENDIF FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
var S, Pa: PathStr; var S, Pa: PathStr;
I, J: longint; I, J: longint;
@ -42,15 +61,16 @@ begin
if Pa [I] = '/' then if Pa [I] = '/' then
Pa [I] := DirSep; Pa [I] := DirSep;
{$ENDIF} {$ENDIF}
{$IFDEF FEXPAND_TILDE} {$IFDEF FPC_FEXPAND_TILDE}
{Replace ~/ with $HOME} {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 begin
{$IFDEF FEXPAND_GETENV_PCHAR} {$IFDEF FPC_FEXPAND_GETENV_PCHAR}
S := StrPas (GetEnv ('HOME')); S := StrPas (GetEnv ('HOME'));
{$ELSE FEXPAND_GETENV_PCHAR} {$ELSE FPC_FEXPAND_GETENV_PCHAR}
S := GetEnv ('HOME'); S := GetEnv ('HOME');
{$ENDIF FEXPAND_GETENV_PCHAR} {$ENDIF FPC_FEXPAND_GETENV_PCHAR}
if (S = '') or (Length (S) = 1) and (S [1] = DirSep) then if (S = '') or (Length (S) = 1) and (S [1] = DirSep) then
Delete (Pa, 1, 1) Delete (Pa, 1, 1)
else else
@ -59,27 +79,15 @@ begin
else else
Pa := S + Copy (Pa, 2, Pred (Length (Pa))); Pa := S + Copy (Pa, 2, Pred (Length (Pa)));
end; end;
{$ENDIF FEXPAND_TILDE} {$ENDIF FPC_FEXPAND_TILDE}
if (Length (Pa) > 1) and (Pa [1] in ['A'..'Z', 'a'..'z']) and if (Length (Pa) > 1) and (Pa [1] in ['A'..'Z', 'a'..'z']) and
(Pa [2] = ':') then (Pa [2] = ':') then
begin begin
{$IFDEF FEXPAND_DRIVES} {$IFDEF FPC_FEXPAND_DRIVES}
{ Always uppercase driveletter } { Always uppercase driveletter }
if (Pa [1] in ['a'..'z']) then if (Pa [1] in ['a'..'z']) then
Pa [1] := Chr (Ord (Pa [1]) and not ($20)); Pa [1] := Chr (Ord (Pa [1]) and not ($20));
{We must get the right directory (should be changed to avoid if GetDirIO (Ord (Pa [1]) - Ord ('A') + 1, S) = 0 then ;
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}
case Length (Pa) of case Length (Pa) of
2: Pa := S; 2: Pa := S;
else else
@ -96,35 +104,25 @@ begin
end; end;
end end
else else
{$ELSE FEXPAND_DRIVES} {$ELSE FPC_FEXPAND_DRIVES}
Delete (Path, 1, 2); Delete (Path, 1, 2);
Delete (Pa, 1, 2); Delete (Pa, 1, 2);
end; end;
{$ENDIF FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
begin begin
{$IFOPT I+} if GetDirIO (0, S) = 0 then ;
{$DEFINE FEXPAND_WAS_I} {$IFDEF FPC_FEXPAND_DRIVES}
{$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 (Length (Pa) > 0) and (Pa [1] = DirSep) then if (Length (Pa) > 0) and (Pa [1] = DirSep) then
begin begin
{$IFDEF FEXPAND_UNC} {$IFDEF FPC_FEXPAND_UNC}
{ Do not touch Network drive names } { Do not touch Network drive names }
if not ((Length (Pa) > 1) and (Pa [2] = Pa [1]) if not ((Length (Pa) > 1) and (Pa [2] = Pa [1])
and LFNSupport) then and LFNSupport) then
{$ENDIF FEXPAND_UNC} {$ENDIF FPC_FEXPAND_UNC}
Pa := S [1] + ':' + Pa Pa := S [1] + ':' + Pa
end end
else else
{$ENDIF FEXPAND_DRIVES} {$ENDIF FPC_FEXPAND_DRIVES}
(* We already have a slash if root is the curent directory. *) (* We already have a slash if root is the curent directory. *)
if Length (S) = PathStart then if Length (S) = PathStart then
Pa := S + Pa Pa := S + Pa
@ -151,9 +149,9 @@ begin
while (J > 0) and (Pa [J] <> DirSep) do while (J > 0) and (Pa [J] <> DirSep) do
Dec (J); Dec (J);
if (J = 0) if (J = 0)
{$IFDEF FEXPAND_UNC} {$IFDEF FPC_FEXPAND_UNC}
or (J = 1) and (I = 2) or (J = 1) and (I = 2)
{$ENDIF FEXPAND_UNC} {$ENDIF FPC_FEXPAND_UNC}
then then
Delete (Pa, Succ (I), 3) Delete (Pa, Succ (I), 3)
else else
@ -169,9 +167,9 @@ begin
while (J >= 1) and (Pa [J] <> DirSep) do while (J >= 1) and (Pa [J] <> DirSep) do
Dec (J); Dec (J);
if (J = 0) if (J = 0)
{$IFDEF FEXPAND_UNC} {$IFDEF FPC_FEXPAND_UNC}
or (J = 1) and (I = 2) or (J = 1) and (I = 2)
{$ENDIF FEXPAND_UNC} {$ENDIF FPC_FEXPAND_UNC}
then then
Delete (Pa, Succ (I), 2) Delete (Pa, Succ (I), 2)
else else
@ -180,14 +178,15 @@ begin
{Now remove also any reference to '\.' at the end of line} {Now remove also any reference to '\.' at the end of line}
I := Pos (DirSep + '.', Pa); I := Pos (DirSep + '.', Pa);
if (I <> 0) and (I = Pred (Length (Pa))) then if (I <> 0) and (I = Pred (Length (Pa))) then
if (I = PathStart) {$IFDEF FPC_FEXPAND_DRIVES}
{$IFDEF FEXPAND_DRIVES} if (I = 3) and (Pa [2] = ':')
and (Pa [2] = ':') {$ELSE FPC_FEXPAND_DRIVES}
{$ENDIF FEXPAND_DRIVES} if (I = 1)
{$IFDEF FEXPAND_UNC} {$ENDIF FPC_FEXPAND_DRIVES}
or (I = 2) and (Pa [1] = '\') {$IFDEF FPC_FEXPAND_UNC}
{$ENDIF FEXPAND_UNC} or (I = 2) and (Pa [1] = '\')
then {$ENDIF FPC_FEXPAND_UNC}
then
Dec (Pa [0]) Dec (Pa [0])
else else
Delete (Pa, I, 2); Delete (Pa, I, 2);
@ -198,3 +197,11 @@ begin
Dec (Pa [0]); Dec (Pa [0]);
FExpand := Pa; FExpand := Pa;
end; 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; var LastSR: SearchRec;
envc: longint; external name '_envc'; envc: longint; external name '_envc';
EnvP: ppchar; external name '_environ';
type TBA = array [1..SizeOf (SearchRec)] of byte; type TBA = array [1..SizeOf (SearchRec)] of byte;
PBA = ^TBA; PBA = ^TBA;
@ -460,31 +461,27 @@ begin
Oh boy, I always had the opinion that executing a program under Dos Oh boy, I always had the opinion that executing a program under Dos
was a hard job!} was a hard job!}
{$ASMMODE DIRECT}
asm asm
movl env,%edi {Setup destination pointer.} movl env,%edi {Setup destination pointer.}
movl _envc,%ecx {Load number of arguments in edx.} movl envc,%ecx {Load number of arguments in edx.}
movl _environ,%esi {Load env. strings.} movl envp,%esi {Load env. strings.}
xorl %edx,%edx {Count environment size.} xorl %edx,%edx {Count environment size.}
exa1: .Lexa1:
lodsl {Load a Pchar.} lodsl {Load a Pchar.}
xchgl %eax,%ebx xchgl %eax,%ebx
exa2: .Lexa2:
movb (%ebx),%al {Load a byte.} movb (%ebx),%al {Load a byte.}
incl %ebx {Point to next byte.} incl %ebx {Point to next byte.}
stosb {Store it.} stosb {Store it.}
incl %edx {Increase counter.} incl %edx {Increase counter.}
cmpb $0,%al {Ready ?.} cmpb $0,%al {Ready ?.}
jne exa2 jne .Lexa2
loop exa1 {Next argument.} loop .Lexa1 {Next argument.}
stosb {Store an extra 0 to finish. (AL is now 0).} stosb {Store an extra 0 to finish. (AL is now 0).}
incl %edx incl %edx
movl %edx,(24)es {Store environment size.} movw %dx,ES.SizeEnv {Store environment size.}
end; end;
{$ASMMODE ATT}
{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;
@ -988,17 +985,21 @@ begin
name:=path; name:=path;
end; end;
(*
function FExpand (const Path: PathStr): PathStr; function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FEXPAND_UNC} (* UNC paths are supported *) {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FEXPAND_DRIVES} (* Full paths begin with drive specification *) {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
const const
LFNSupport = true; LFNSupport = true;
{$I fexpand.inc} {$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); procedure packtime(var d:datetime;var time:longint);
@ -1066,7 +1067,10 @@ end;
end. end.
{ {
$Log$ $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 * direct asm removing
Revision 1.6 2000/11/06 20:35:05 hajny Revision 1.6 2000/11/06 20:35:05 hajny

30
rtl/os2/system.pas
View File

@ -771,25 +771,32 @@ end;
{$ASMMODE ATT} {$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.} {Written by Michael Van Canneyt.}
var temp:array[0..255] of char; var sof:Pchar;
sof:Pchar;
i:byte; i:byte;
IOR: word;
begin begin
Dir [4] := #0;
{ Used in case the specified drive isn't available }
sof:=pchar(@dir[4]); sof:=pchar(@dir[4]);
{ dir[1..3] will contain '[drivenr]:\', but is not } { dir[1..3] will contain '[drivenr]:\', but is not }
{ 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
movw %ax, IOR
.LGetDir:
end; end;
{ Now Dir should be filled with directory in ASCIIZ, } { Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] } { starting from dir[4] }
@ -807,9 +814,8 @@ begin
inc(i); inc(i);
end; end;
{ upcase the string (FPC function) } { upcase the string (FPC function) }
if not (FileNameCaseSensitive) then dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it } if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=char(65+drivenr-1) dir[1]:=chr(64+drivenr)
else else
begin begin
{ We need to get the current drive from DOS function 19H } { We need to get the current drive from DOS function 19H }
@ -822,13 +828,21 @@ begin
end; end;
dir[1]:=char(i); dir[1]:=char(i);
end; end;
if not (FileNameCaseSensitive) then dir:=upcase(dir);
GetDirIO := IOR;
end; end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
begin
InOutRes := GetDirIO (DriveNr, Dir);
end;
{**************************************************************************** {****************************************************************************
Thread Handling Thread Handling
*****************************************************************************} *****************************************************************************}
const const
@ -845,6 +859,7 @@ end;
{$I thread.inc} {$I thread.inc}
{***************************************************************************** {*****************************************************************************
System unit initialization. System unit initialization.
****************************************************************************} ****************************************************************************}
@ -949,7 +964,10 @@ begin
end. end.
{ {
$Log$ $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 * chdir,mkdir,rmdir with empty string fixed
Revision 1.7 2001/02/04 01:57:52 hajny Revision 1.7 2001/02/04 01:57:52 hajny