paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-25 12:41:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
c2fe8dbd99
fpc/compiler/dmisc.pas
carl 67486c96c3 * fixes for Delphi 6 compilation 
(warning : Some features do not work under Delphi)
2002-10-05 12:43:23 +00:00

877 lines
21 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
Dos unit for BP7 compatible RTL for Delphi
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit dmisc;
{$i fpcdefs.inc}
interface
{$ifndef linux}
{$define MSWindows}
{$endif}
uses
{$ifdef linux}
Libc,
{$else}
windows,
{$endif}
sysutils;
Const
Max_Path = 255;
{Bitmasks for CPU Flags}
fcarry = $0001;
fparity = $0004;
fauxiliary = $0010;
fzero = $0040;
fsign = $0080;
foverflow = $0800;
{Bitmasks for file attribute}
readonly = $01;
hidden = $02;
sysfile = $04;
volumeid = $08;
directory = $10;
archive = $20;
anyfile = $3F;
{File Status}
fmclosed = $D7B0;
fminput = $D7B1;
fmoutput = $D7B2;
fminout = $D7B3;
Type
DWord = Cardinal;
qword = int64;
tlongint = array[0..65535] of longint;
plongintarray = ^tlongint;
{ Needed for Win95 LFN Support }
ComStr = String[255];
PathStr = String[255];
DirStr = String[255];
NameStr = String[255];
ExtStr = String[255];
FileRec = TFileRec;
DateTime = packed record
Year,
Month,
Day,
Hour,
Min,
Sec : word;
End;
SearchRec = Sysutils.TSearchRec;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
Var
DosError : integer;
{Interrupt}
Procedure Intr(intno: byte; var regs: registers);
Procedure MSDos(var regs: registers);
{Info/Date/Time}
Function DosVersion: Word;
Procedure GetDate(var year, month, mday, wday: word);
Procedure GetTime(var hour, minute, second, sec100: word);
Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);
{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function DosExitCode: word;
{Disk}
Function DiskFree(drive: byte) : int64;
Function DiskSize(drive: byte) : int64;
Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(Var f: SearchRec);
{File}
Procedure GetFAttr(var f; var attr: word);
Procedure GetFTime(var f; var tim: longint);
Function FSearch(path: pathstr; dirlist: string): pathstr;
Function FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
{Environment}
Function EnvCount: longint;
Function EnvStr(index: integer): string;
Function GetEnv(envvar: string): string;
{Misc}
Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetCBreak(var breakvalue: boolean);
Procedure SetCBreak(breakvalue: boolean);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);
{Memory}
function CompareByte(const buf1,buf2;len:longint):longint;
{Do Nothing Functions}
Procedure SwapVectors;
Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);
implementation
function CompareByte(const buf1,buf2;len:longint):longint;
begin
{ Both buffers are similar }
if comparemem(@buf1, @buf2, len) then
CompareByte := 0
else
CompareByte := 1;
end;
function upper(const s : string) : string;
{
return uppercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
{******************************************************************************
--- Conversion ---
******************************************************************************}
{$ifdef MSWindows}
function GetLastError : DWORD;stdcall;
external 'Kernel32.dll' name 'GetLastError';
function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;stdcall;
external 'Kernel32.dll' name 'FileTimeToDosDateTime';
function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'DosDateTimeToFileTime';
function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'FileTimeToLocalFileTime';
function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;stdcall;
external 'Kernel32.dll' name 'LocalFileTimeToFileTime';
type
Longrec=packed record
lo,hi : word;
end;
function Last2DosError(d:dword):integer;
begin
Last2DosError:=d;
end;
Function DosToWinAttr (Const Attr : Longint) : longint;
begin
DosToWinAttr:=Attr;
end;
Function WinToDosAttr (Const Attr : Longint) : longint;
begin
WinToDosAttr:=Attr;
end;
Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
var
lft : TFileTime;
begin
DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
LocalFileTimeToFileTime(lft,Wtime);
end;
Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
var
lft : TFileTime;
begin
WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
end;
{$endif}
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
procedure intr(intno : byte;var regs : registers);
begin
{ !!!!!!!! }
end;
procedure msdos(var regs : registers);
begin
{ !!!!!!!! }
end;
{******************************************************************************
--- Info / Date / Time ---
******************************************************************************}
function dosversion : word;
begin
dosversion:=0;
end;
procedure getdate(var year,month,mday,wday : word);
begin
DecodeDate(Now,Year,Month,MDay);
WDay:=0;
// DecodeDateFully(Now,Year,Month,MDay,WDay);
end;
procedure gettime(var hour,minute,second,sec100 : word);
begin
DecodeTime(Now,Hour,Minute,Second,Sec100);
Sec100:=Sec100 div 10;
end;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin
sec:=(p and 31) shl 1;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end;
End;
{******************************************************************************
--- Exec ---
******************************************************************************}
var
lastdosexitcode : word;
{$ifdef MSWindows}
procedure exec(const path : pathstr;const comline : comstr);
var
SI: TStartupInfo;
PI: TProcessInformation;
Proc : THandle;
l : DWord;
AppPath,
AppParam : array[0..255] of char;
begin
FillChar(SI, SizeOf(SI), 0);
SI.cb:=SizeOf(SI);
SI.wShowWindow:=1;
Move(Path[1],AppPath,length(Path));
AppPath[Length(Path)]:=#0;
AppParam[0]:='-';
AppParam[1]:=' ';
Move(ComLine[1],AppParam[2],length(Comline));
AppParam[Length(ComLine)+2]:=#0;
if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
begin
DosError:=Last2DosError(GetLastError);
exit;
end
else
DosError:=0;
Proc:=PI.hProcess;
CloseHandle(PI.hThread);
if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
GetExitCodeProcess(Proc,l)
else
l:=$ffffffff;
CloseHandle(Proc);
LastDosExitCode:=l;
end;
{$endif MSWindows}
{$ifdef Linux}
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var
pid,status : longint;
Begin
LastDosExitCode:=0;
pid:=Fork;
if pid=0 then
begin
{The child does the actual exec, and then exits}
Execl(@Path[1],@ComLine[1]);
{If the execve fails, we return an exitvalue of 127, to let it be known}
__exit(127);
end
else
if pid=-1 then {Fork failed}
begin
DosError:=8;
exit
end;
{We're in the parent, let's wait.}
WaitPid(Pid,@Status,0);
LastDosExitCode:=Status; // WaitPid and result-convert
if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
DosError:=0
else
DosError:=8; // perhaps one time give an better error
End;
{$endif Linux}
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure swapvectors;
begin
end;
procedure getcbreak(var breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure setcbreak(breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure getverify(var verify : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure setverify(verify : boolean);
begin
{ !! No Win32 Function !! }
end;
{******************************************************************************
--- Disk ---
******************************************************************************}
{$ifdef Linux]
{
The Diskfree and Disksize functions need a file on the specified drive, since this
is required for the statfs system call.
These filenames are set in drivestr[0..26], and have been preset to :
0 - '.' (default drive - hence current dir is ok.)
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
3 - '/' (C: equivalent of dos is the root partition)
4..26 (can be set by you're own applications)
! Use AddDisk() to Add new drives !
They both return -1 when a failure occurs.
}
Const
FixDriveStr : array[0..3] of pchar=(
'.',
'/fd0/.',
'/fd1/.',
'/.'
);
var
Drives : byte = 4;
var
DriveStr : array[4..26] of pchar;
Procedure AddDisk(const path:string);
begin
if not (DriveStr[Drives]=nil) then
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
GetMem(DriveStr[Drives],length(Path)+1);
StrPCopy(DriveStr[Drives],path);
inc(Drives);
if Drives>26 then
Drives:=4;
end;
Function DiskFree(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
Diskfree:=int64(fs.f_bavail)*int64(fs.f_bsize)
else
Diskfree:=-1;
End;
Function DiskSize(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(fixdrivestr[drive],fs)=0)) or
((not (drivestr[Drive]=nil)) and (statfs(drivestr[drive],fs)=0)) then
Disksize:=int64(fs.f_blocks)*int64(fs.f_bsize)
else
Disksize:=-1;
End;
{$else linux}
function diskfree(drive : byte) : int64;
begin
DiskFree:=SysUtils.DiskFree(drive);
end;
function disksize(drive : byte) : int64;
begin
DiskSize:=SysUtils.DiskSize(drive);
end;
{$endif linux}
{******************************************************************************
--- Findfirst FindNext ---
******************************************************************************}
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
begin
DosError:=SysUtils.FindFirst(Path,Attr,f);
end;
procedure findnext(var f : searchRec);
begin
DosError:=Sysutils.FindNext(f);
end;
Procedure FindClose(Var f: SearchRec);
begin
Sysutils.FindClose(f);
end;
{******************************************************************************
--- File ---
******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;
function fexpand(const path : pathstr) : pathstr;
var
s,pa : string[79];
i,j : longint;
begin
getdir(0,s);
pa:=upper(path);
{ allow slash as backslash }
for i:=1 to length(pa) do
if pa[i]='/' then
pa[i]:='\';
if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') 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
pa:=s+'\'+copy (pa,3,length(pa))
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! }
if length(pa) = 2 then
begin
getdir(byte(pa[1])-64,s);
pa := s;
end;
{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(path) = 2 then pa := pa + '\';
fexpand:=pa;
end;
Function FSearch(path: pathstr; dirlist: string): pathstr;
var
i,p1 : longint;
s : searchrec;
newdir : pathstr;
begin
{ No wildcards allowed in these things }
if (pos('?',path)<>0) or (pos('*',path)<>0) then
fsearch:=''
else
begin
{ allow slash as backslash }
for i:=1 to length(dirlist) do
if dirlist[i]='/' then dirlist[i]:='\';
repeat
p1:=pos(';',dirlist);
if p1=0 then
begin
newdir:=copy(dirlist,1,p1-1);
delete(dirlist,1,p1);
end
else
begin
newdir:=dirlist;
dirlist:='';
end;
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
newdir:=newdir+'\';
findfirst(newdir+path,anyfile,s);
if doserror=0 then
newdir:=newdir+path
else
newdir:='';
until (dirlist='') or (newdir<>'');
fsearch:=newdir;
end;
end;
procedure getftime(var f;var tim : longint);
begin
tim:=FileGetDate(filerec(f).handle);
end;
procedure setftime(var f;time : longint);
begin
{$ifdef linux}
FileSetDate(filerec(f).name,Time);
{$else}
FileSetDate(filerec(f).handle,Time);
{$endif}
end;
{$ifdef linux}
procedure getfattr(var f;var attr : word);
Var
info : tstatbuf;
LinAttr : longint;
Begin
DosError:=0;
if (FStat(filerec(f).handle,info)<>0) then
begin
Attr:=0;
DosError:=3;
exit;
end
else
LinAttr:=Info.st_Mode;
if S_ISDIR(LinAttr) then
Attr:=$10
else
Attr:=$20;
if Access(@filerec(f).name,W_OK)<>0 then
Attr:=Attr or $1;
if (not S_ISDIR(LinAttr)) and (filerec(f).name[0]='.') then
Attr:=Attr or $2;
end;
{$else}
procedure getfattr(var f;var attr : word);
var
l : longint;
begin
l:=FileGetAttr(filerec(f).name);
attr:=l;
end;
{$endif}
procedure setfattr(var f;attr : word);
begin
{$ifdef MSWindows}
FileSetAttr(filerec(f).name,attr);
{$endif}
end;
{******************************************************************************
--- Environment ---
******************************************************************************}
{
The environment is a block of zero terminated strings
terminated by a #0
}
{$ifdef MSWindows}
function GetEnvironmentStrings : pchar;stdcall;
external 'Kernel32.dll' name 'GetEnvironmentStringsA';
function FreeEnvironmentStrings(p : pchar) : boolean;stdcall;
external 'Kernel32.dll' name 'FreeEnvironmentStringsA';
function envcount : longint;
var
hp,p : pchar;
count : longint;
begin
p:=GetEnvironmentStrings;
hp:=p;
count:=0;
while hp^<>#0 do
begin
{ next string entry}
hp:=hp+strlen(hp)+1;
inc(count);
end;
FreeEnvironmentStrings(p);
envcount:=count;
end;
Function EnvStr(index: integer): string;
var
hp,p : pchar;
count,i : longint;
begin
{ envcount takes some time in win32 }
count:=envcount;
{ range checking }
if (index<=0) or (index>count) then
begin
envstr:='';
exit;
end;
p:=GetEnvironmentStrings;
hp:=p;
{ retrive the string with the given index }
for i:=2 to index do
hp:=hp+strlen(hp)+1;
envstr:=strpas(hp);
FreeEnvironmentStrings(p);
end;
Function GetEnv(envvar: string): string;
var
s : string;
i : longint;
hp,p : pchar;
begin
getenv:='';
p:=GetEnvironmentStrings;
hp:=p;
while hp^<>#0 do
begin
s:=strpas(hp);
i:=pos('=',s);
if copy(s,1,i-1)=envvar then
begin
getenv:=copy(s,i+1,length(s)-i);
break;
end;
{ next string entry}
hp:=hp+strlen(hp)+1;
end;
FreeEnvironmentStrings(p);
end;
{$else}
function envcount : longint;
begin
envcount:=0;
end;
Function EnvStr(index: integer): string;
begin
envstr:='';
end;
Function GetEnv(envvar: string): string;
begin
getenv:=GetEnvironmentVariable(envvar);
end;
{$endif}
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
end.
{
$Log$
Revision 1.11 2002-10-05 12:43:24 carl
* fixes for Delphi 6 compilation
(warning : Some features do not work under Delphi)
Revision 1.10 2002/08/12 15:08:39 carl
+ stab register indexes for powerpc (moved from gdb to cpubase)
+ tprocessor enumeration moved to cpuinfo
+ linker in target_info is now a class
* many many updates for m68k (will soon start to compile)
- removed some ifdef or correct them for correct cpu
Revision 1.9 2002/05/18 13:34:07 peter
* readded missing revisions
Revision 1.8 2002/05/16 19:46:36 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
}
Reference in New Issue View Git Blame Copy Permalink