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

* moved file and dir functions to sysfile/sysdir

Browse Source 
* win32 thread in systemunit
This commit is contained in:
peter 2005-02-06 13:06:20 +00:00
parent f5bc749953
commit 86025bbcb6
24 changed files with 1751 additions and 1604 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

354
rtl/bsd/osmain.inc
View File

@ -14,18 +14,6 @@
**********************************************************************}
const
{ Default creation mode for directories and files }
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
{ read/write search permission for everyone }
MODE_MKDIR = MODE_OPEN OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
{*****************************************************************************
Misc. System Dependent Functions
*****************************************************************************}
@ -132,342 +120,6 @@ begin
InoutRes:=Errno2InoutRes;
end;
Procedure Do_Close(Handle:thandle);
Begin
Fpclose(cint(Handle));
End;
Procedure Do_Erase(p:pchar);
var
fileinfo : stat;
Begin
{ verify if the filename is actually a directory }
{ if so return error and do nothing, as defined }
{ by POSIX }
if Fpstat(p,fileinfo)<0 then
begin
Errno2Inoutres;
exit;
end;
if FpS_ISDIR(fileinfo.st_mode) then
begin
InOutRes := 2;
exit;
end;
if Fpunlink(p)<0 then
Errno2Inoutres
Else
InOutRes:=0;
End;
{ truncate at a given position }
procedure do_truncate (handle:thandle;fpos:longint);
begin
{ should be simulated in cases where it is not }
{ available. }
If Fpftruncate(handle,fpos)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Procedure Do_Rename(p1,p2:pchar);
Begin
If Fprename(p1,p2)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_Write(Handle:thandle;Addr:Pointer;Len:Longint):longint;
var j : cint;
Begin
repeat
Do_Write:=Fpwrite(Handle,addr,len);
j:=geterrno;
until (do_write<>-1) or ((j<>ESysEINTR) and (j<>ESysEAgain));
If Do_Write<0 Then
Begin
Errno2InOutRes;
Do_Write:=0;
End
else
InOutRes:=0;
End;
Function Do_Read(Handle:thandle;Addr:Pointer;Len:Longint):Longint;
var j:cint;
Begin
repeat
Do_Read:=Fpread(Handle,addr,len);
j:=geterrno;
until (do_read<>-1) or ((j<>ESysEINTR) and (j<>ESysEAgain));
If Do_Read<0 Then
Begin
Errno2InOutRes;
Do_Read:=0;
End
else
InOutRes:=0;
End;
function Do_FilePos(Handle: thandle):longint;
Begin
do_FilePos:=Fplseek(Handle, 0, SEEK_CUR);
If Do_FilePos<0 Then
Errno2InOutRes
else
InOutRes:=0;
End;
Procedure Do_Seek(Handle:thandle;Pos:Longint);
Begin
If Fplseek(Handle, pos, SEEK_SET)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_SeekEnd(Handle:thandle): Longint;
begin
Do_SeekEnd:=Fplseek(Handle,0,SEEK_END);
If Do_SeekEnd<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Function Do_FileSize(Handle:thandle): Longint;
var
Info : Stat;
Ret : Longint;
Begin
Ret:=Fpfstat(handle,info);
If Ret=0 Then
Do_FileSize:=Info.st_size
else
Do_FileSize:=0;
If Ret<0 Then
Errno2InOutRes
Else
InOutRes:=0;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : cint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags :=O_RDONLY;
FileRec(f).mode:=fminput;
end;
1 : begin
oflags :=O_WRONLY;
FileRec(f).mode:=fmoutput;
end;
2 : begin
oflags :=O_RDWR;
FileRec(f).mode:=fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
if (FileRec(f).Handle<0) and
(getErrNo=ESysEROFS) and ((OFlags and O_RDWR)<>0) then
begin
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
end;
If Filerec(f).Handle<0 Then
Errno2Inoutres
else
InOutRes:=0;
End;
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpmkdir(@buffer, MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
if (s = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fprmdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpchdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;
End;
{ // $define usegetcwd}
procedure getdir(drivenr : byte;var dir : shortstring);
var
{$ifndef usegetcwd}
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
name : string[255];
thisdir : stat;
{$endif}
tmp : string[255];
begin
{$ifdef usegetcwd}
Fpgetcwd(@tmp[1],4096);
dir:=tmp;
{$else}
dir:='';
thedir:='';
dummy:='';
{ get root directory information }
tmp := '/'+#0;
if Fpstat(@tmp[1],rootinfo)<0 then
Exit;
repeat
tmp := dummy+'.'+#0;
{ get current directory information }
if Fpstat(@tmp[1],cwdinfo)<0 then
Exit;
tmp:=dummy+'..'+#0;
{ open directory stream }
{ try to find the current inode number of the cwd }
dirstream:=Fpopendir(@tmp[1]);
if dirstream=nil then
exit;
repeat
name:='';
d:=Fpreaddir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
break;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
if (Fpstat(@tmp[1],thisdir)=0) then
begin
{ found the entry for this directory name }
if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
begin
{ are the filenames of type '.' or '..' ? }
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
name:='/'+strpas(d^.d_name);
end;
end;
until (name<>'');
if Fpclosedir(dirstream)<0 then
Exit;
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
else
dir:=thedir;
exit;
end;
until false;
{$endif}
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
@ -570,7 +222,11 @@ end;
{
$Log$
Revision 1.16 2004-10-25 15:38:59 peter
Revision 1.17 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.16 2004/10/25 15:38:59 peter
* compiler defined HEAP and HEAPSIZE removed
Revision 1.15 2004/07/17 15:20:55 jonas

152
rtl/bsd/sysdir.inc Normal file
View File

@ -0,0 +1,152 @@
{
$Id$
This file is part of the Free Pascal run time library.
Main OS dependant body of the system unit, loosely modelled
after POSIX. *BSD version (Linux version is near identical)
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.
**********************************************************************}
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpmkdir(@buffer, MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
if (s = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fprmdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpchdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;
End;
{ // $define usegetcwd}
procedure getdir(drivenr : byte;var dir : shortstring);
var
{$ifndef usegetcwd}
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
name : string[255];
thisdir : stat;
{$endif}
tmp : string[255];
begin
{$ifdef usegetcwd}
Fpgetcwd(@tmp[1],4096);
dir:=tmp;
{$else}
dir:='';
thedir:='';
dummy:='';
{ get root directory information }
tmp := '/'+#0;
if Fpstat(@tmp[1],rootinfo)<0 then
Exit;
repeat
tmp := dummy+'.'+#0;
{ get current directory information }
if Fpstat(@tmp[1],cwdinfo)<0 then
Exit;
tmp:=dummy+'..'+#0;
{ open directory stream }
{ try to find the current inode number of the cwd }
dirstream:=Fpopendir(@tmp[1]);
if dirstream=nil then
exit;
repeat
name:='';
d:=Fpreaddir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
break;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
if (Fpstat(@tmp[1],thisdir)=0) then
begin
{ found the entry for this directory name }
if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
begin
{ are the filenames of type '.' or '..' ? }
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
name:='/'+strpas(d^.d_name);
end;
end;
until (name<>'');
if Fpclosedir(dirstream)<0 then
Exit;
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
else
dir:=thedir;
exit;
end;
until false;
{$endif}
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

230
rtl/bsd/sysfile.inc Normal file
View File

@ -0,0 +1,230 @@
{
$Id$
This file is part of the Free Pascal run time library.
Main OS dependant body of the system unit, loosely modelled
after POSIX. *BSD version (Linux version is near identical)
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.
**********************************************************************}
Procedure Do_Close(Handle:thandle);
Begin
Fpclose(cint(Handle));
End;
Procedure Do_Erase(p:pchar);
var
fileinfo : stat;
Begin
{ verify if the filename is actually a directory }
{ if so return error and do nothing, as defined }
{ by POSIX }
if Fpstat(p,fileinfo)<0 then
begin
Errno2Inoutres;
exit;
end;
if FpS_ISDIR(fileinfo.st_mode) then
begin
InOutRes := 2;
exit;
end;
if Fpunlink(p)<0 then
Errno2Inoutres
Else
InOutRes:=0;
End;
{ truncate at a given position }
procedure do_truncate (handle:thandle;fpos:longint);
begin
{ should be simulated in cases where it is not }
{ available. }
If Fpftruncate(handle,fpos)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Procedure Do_Rename(p1,p2:pchar);
Begin
If Fprename(p1,p2)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_Write(Handle:thandle;Addr:Pointer;Len:Longint):longint;
var j : cint;
Begin
repeat
Do_Write:=Fpwrite(Handle,addr,len);
j:=geterrno;
until (do_write<>-1) or ((j<>ESysEINTR) and (j<>ESysEAgain));
If Do_Write<0 Then
Begin
Errno2InOutRes;
Do_Write:=0;
End
else
InOutRes:=0;
End;
Function Do_Read(Handle:thandle;Addr:Pointer;Len:Longint):Longint;
var j:cint;
Begin
repeat
Do_Read:=Fpread(Handle,addr,len);
j:=geterrno;
until (do_read<>-1) or ((j<>ESysEINTR) and (j<>ESysEAgain));
If Do_Read<0 Then
Begin
Errno2InOutRes;
Do_Read:=0;
End
else
InOutRes:=0;
End;
function Do_FilePos(Handle: thandle):longint;
Begin
do_FilePos:=Fplseek(Handle, 0, SEEK_CUR);
If Do_FilePos<0 Then
Errno2InOutRes
else
InOutRes:=0;
End;
Procedure Do_Seek(Handle:thandle;Pos:Longint);
Begin
If Fplseek(Handle, pos, SEEK_SET)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_SeekEnd(Handle:thandle): Longint;
begin
Do_SeekEnd:=Fplseek(Handle,0,SEEK_END);
If Do_SeekEnd<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Function Do_FileSize(Handle:thandle): Longint;
var
Info : Stat;
Ret : Longint;
Begin
Ret:=Fpfstat(handle,info);
If Ret=0 Then
Do_FileSize:=Info.st_size
else
Do_FileSize:=0;
If Ret<0 Then
Errno2InOutRes
Else
InOutRes:=0;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : cint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags :=O_RDONLY;
FileRec(f).mode:=fminput;
end;
1 : begin
oflags :=O_WRONLY;
FileRec(f).mode:=fmoutput;
end;
2 : begin
oflags :=O_RDWR;
FileRec(f).mode:=fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
if (FileRec(f).Handle<0) and
(getErrNo=ESysEROFS) and ((OFlags and O_RDWR)<>0) then
begin
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
end;
If Filerec(f).Handle<0 Then
Errno2Inoutres
else
InOutRes:=0;
End;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

17
rtl/bsd/sysos.inc
View File

@ -87,11 +87,26 @@ end;
{$I ossysc.inc}
{$I osmain.inc}
const
{ Default creation mode for directories and files }
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
{ read/write search permission for everyone }
MODE_MKDIR = MODE_OPEN OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
{
$Log$
Revision 1.1 2005-02-06 12:16:52 peter
Revision 1.2 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.1 2005/02/06 12:16:52 peter
* bsd thread updates
}

10
rtl/freebsd/sysconst.inc
View File

@ -90,10 +90,6 @@ const
fs_proc = $9fa0;
fs_xia = $012FD16D;
{ Constansts for MMAP }
MAP_PRIVATE =2;
MAP_ANONYMOUS =$1000;
{Constansts Termios/Ioctl (used in Do_IsDevice) }
IOCtl_TCGETS= $40000000+$2C7400+ 19; // TCGETS is also in termios.inc, but the sysunix needs only this
@ -117,7 +113,11 @@ type
{
$Log$
Revision 1.10 2004-11-14 12:21:08 marco
Revision 1.11 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.10 2004/11/14 12:21:08 marco
* moved some calls from unix to baseunix. Darwin untested.
Revision 1.9 2003/11/19 10:12:02 marco

87
rtl/inc/system.inc
View File

@ -850,7 +850,7 @@ var p : ppchar;
begin
if High(s)<Low(s) Then Exit(NIL);
Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
// for cmd
// for cmd
if p=nil then
begin
{$ifdef xunix}
@ -886,23 +886,23 @@ begin
buf:=s;
nr:=1;
InQuote:=false;
while (buf^<>#0) do // count nr of args
while (buf^<>#0) do // count nr of args
begin
while (buf^ in [' ',#9,#10]) do // Kill separators.
while (buf^ in [' ',#9,#10]) do // Kill separators.
inc(buf);
inc(nr);
if buf^='"' Then // quotes argument?
if buf^='"' Then // quotes argument?
begin
inc(buf);
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
inc(buf);
if buf^='"' then // skip closing quote.
inc(buf);
inc(buf);
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
inc(buf);
if buf^='"' then // skip closing quote.
inc(buf);
end
else
begin // else std
while not (buf^ in [' ',#0,#9,#10]) do
inc(buf);
begin // else std
while not (buf^ in [' ',#0,#9,#10]) do
inc(buf);
end;
end;
getmem(p,(ReserveEntries+nr)*sizeof(pchar));
@ -914,36 +914,36 @@ begin
{$endif}
exit;
end;
for i:=1 to ReserveEntries do inc(p); // skip empty slots
for i:=1 to ReserveEntries do inc(p); // skip empty slots
buf:=s;
while (buf^<>#0) do
begin
while (buf^ in [' ',#9,#10]) do // Kill separators.
while (buf^ in [' ',#9,#10]) do // Kill separators.
begin
buf^:=#0;
inc(buf);
end;
if buf^='"' Then // quotes argument?
if buf^='"' Then // quotes argument?
begin
inc(buf);
inc(buf);
p^:=buf;
inc(p);
p^:=nil;
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
inc(buf);
if buf^='"' then // skip closing quote.
begin
buf^:=#0;
inc(buf);
inc(p);
p^:=nil;
while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
inc(buf);
if buf^='"' then // skip closing quote.
begin
buf^:=#0;
inc(buf);
end;
end
else
begin
p^:=buf;
inc(p);
p^:=nil;
while not (buf^ in [' ',#0,#9,#10]) do
inc(buf);
p^:=buf;
inc(p);
p^:=nil;
while not (buf^ in [' ',#0,#9,#10]) do
inc(buf);
end;
end;
end;
@ -1034,28 +1034,37 @@ end;
{*****************************************************************************
Text File Handling
File Handling
*****************************************************************************}
{$I text.inc}
{ OS dependent low level file functions }
{$i sysfile.inc}
{*****************************************************************************
UnTyped File Handling
*****************************************************************************}
{ Text file }
{$i text.inc}
{ Untyped file }
{$i file.inc}
{*****************************************************************************
Typed File Handling
*****************************************************************************}
{ Typed file }
{$i typefile.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
{ OS dependent dir functions }
{$i sysdir.inc}
{
$Log$
Revision 1.72 2005-02-06 11:20:52 peter
Revision 1.73 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.72 2005/02/06 11:20:52 peter
* threading in system unit
* removed systhrds unit

356
rtl/linux/osmain.inc
View File

@ -16,17 +16,6 @@
**********************************************************************}
const
{ Default creation mode for directories and files }
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
{ read/write search permission for everyone }
MODE_MKDIR = MODE_OPEN OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
{*****************************************************************************
Misc. System Dependent Functions
@ -134,345 +123,6 @@ begin
end;
Procedure Do_Close(Handle:thandle);
Begin
Fpclose(cint(Handle));
End;
Procedure Do_Erase(p:pchar);
var
fileinfo : stat;
Begin
{ verify if the filename is actually a directory }
{ if so return error and do nothing, as defined }
{ by POSIX }
if Fpstat(p,fileinfo)<0 then
begin
Errno2Inoutres;
exit;
end;
if FpS_ISDIR(fileinfo.st_mode) then
begin
InOutRes := 2;
exit;
end;
if Fpunlink(p)<0 then
Errno2Inoutres
Else
InOutRes:=0;
End;
{ truncate at a given position }
procedure do_truncate (handle:thandle;fpos:longint);
begin
{ should be simulated in cases where it is not }
{ available. }
If Fpftruncate(handle,fpos)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Procedure Do_Rename(p1,p2:pchar);
Begin
If Fprename(p1,p2)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_Write(Handle:thandle;Addr:Pointer;Len:SizeInt):SizeInt;
Begin
repeat
Do_Write:=Fpwrite(Handle,addr,len);
until (Do_Write>=0) or (getErrNo<>ESysEINTR);
If Do_Write<0 Then
Begin
Errno2InOutRes;
Do_Write:=0;
End
else
InOutRes:=0;
End;
Function Do_Read(Handle:thandle;Addr:Pointer;Len:SizeInt):SizeInt;
Begin
repeat
Do_Read:=Fpread(Handle,addr,len);
until (Do_Read>=0) or (getErrNo<>ESysEINTR);
If Do_Read<0 Then
Begin
Errno2InOutRes;
Do_Read:=0;
End
else
InOutRes:=0;
End;
function Do_FilePos(Handle: thandle):longint;
Begin
do_FilePos:=Fplseek(Handle, 0, SEEK_CUR);
If Do_FilePos<0 Then
Errno2InOutRes
else
InOutRes:=0;
End;
Procedure Do_Seek(Handle:thandle;Pos:Longint);
Begin
If Fplseek(Handle, pos, SEEK_SET)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_SeekEnd(Handle:thandle): Longint;
begin
Do_SeekEnd:=Fplseek(Handle,0,SEEK_END);
If Do_SeekEnd<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Function Do_FileSize(Handle:thandle): Longint;
var
Info : Stat;
Ret : Longint;
Begin
Ret:=Fpfstat(handle,info);
If Ret=0 Then
Do_FileSize:=Info.st_size
else
Do_FileSize:=0;
If Ret<0 Then
Errno2InOutRes
Else
InOutRes:=0;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : cint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags :=O_RDONLY;
FileRec(f).mode:=fminput;
end;
1 : begin
oflags :=O_WRONLY;
FileRec(f).mode:=fmoutput;
end;
2 : begin
oflags :=O_RDWR;
FileRec(f).mode:=fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
if (FileRec(f).Handle<0) and
(getErrNo=ESysEROFS) and
((OFlags and O_RDWR)<>0) then
begin
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
end;
If Filerec(f).Handle<0 Then
Errno2Inoutres
else
InOutRes:=0;
End;
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpmkdir(@buffer, MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
if (s = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fprmdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpchdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;
End;
procedure getdir(drivenr : byte;var dir : shortstring);
var
{$ifndef usegetcwd}
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
name : string[255];
thisdir : stat;
tmp : string[255];
{$else}
tmp : array[0..4095] of char;
{$endif}
begin
{$ifdef usegetcwd}
if Fpgetcwd(@tmp,10240+512)<>NIL then
dir:=pchar(@tmp)
else
begin
dir:='';
writeln(geterrno);
end;
{$else}
dir:='';
thedir:='';
dummy:='';
{ get root directory information }
tmp := '/'+#0;
if Fpstat(@tmp[1],rootinfo)<0 then
Exit;
repeat
tmp := dummy+'.'+#0;
{ get current directory information }
if Fpstat(@tmp[1],cwdinfo)<0 then
Exit;
tmp:=dummy+'..'+#0;
{ open directory stream }
{ try to find the current inode number of the cwd }
dirstream:=Fpopendir(@tmp[1]);
if dirstream=nil then
exit;
repeat
name:='';
d:=Fpreaddir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
break;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
if (Fpstat(@tmp[1],thisdir)=0) then
begin
{ found the entry for this directory name }
if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
begin
{ are the filenames of type '.' or '..' ? }
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
name:='/'+strpas(d^.d_name);
end;
end;
until (name<>'');
If Fpclosedir(dirstream)<0 THen
Exit;
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
else
dir:=thedir;
exit;
end;
until false;
{$endif}
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
@ -563,7 +213,11 @@ end;
{
$Log$
Revision 1.26 2005-02-05 22:53:43 peter
Revision 1.27 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.26 2005/02/05 22:53:43 peter
* use typecasted sigactionhandler, needed for arm
Revision 1.25 2005/02/03 21:42:17 peter

157
rtl/linux/sysdir.inc Normal file
View File

@ -0,0 +1,157 @@
{
$Id$
This file is part of the Free Pascal run time library.
POSIX Interface to the system unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This is the core of the system unit *nix systems (now FreeBSD
and Unix).
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.
**********************************************************************}
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpmkdir(@buffer, MODE_MKDIR)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
if (s = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fprmdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
If Fpchdir(@buffer)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;
End;
procedure getdir(drivenr : byte;var dir : shortstring);
var
{$ifndef usegetcwd}
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
name : string[255];
thisdir : stat;
tmp : string[255];
{$else}
tmp : array[0..4095] of char;
{$endif}
begin
{$ifdef usegetcwd}
if Fpgetcwd(@tmp,10240+512)<>NIL then
dir:=pchar(@tmp)
else
begin
dir:='';
writeln(geterrno);
end;
{$else}
dir:='';
thedir:='';
dummy:='';
{ get root directory information }
tmp := '/'+#0;
if Fpstat(@tmp[1],rootinfo)<0 then
Exit;
repeat
tmp := dummy+'.'+#0;
{ get current directory information }
if Fpstat(@tmp[1],cwdinfo)<0 then
Exit;
tmp:=dummy+'..'+#0;
{ open directory stream }
{ try to find the current inode number of the cwd }
dirstream:=Fpopendir(@tmp[1]);
if dirstream=nil then
exit;
repeat
name:='';
d:=Fpreaddir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
break;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
if (Fpstat(@tmp[1],thisdir)=0) then
begin
{ found the entry for this directory name }
if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
begin
{ are the filenames of type '.' or '..' ? }
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
name:='/'+strpas(d^.d_name);
end;
end;
until (name<>'');
If Fpclosedir(dirstream)<0 THen
Exit;
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
else
dir:=thedir;
exit;
end;
until false;
{$endif}
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

230
rtl/linux/sysfile.inc Normal file
View File

@ -0,0 +1,230 @@
{
$Id$
This file is part of the Free Pascal run time library.
POSIX Interface to the system unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This is the core of the system unit *nix systems (now FreeBSD
and Unix).
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.
**********************************************************************}
Procedure Do_Close(Handle:thandle);
Begin
Fpclose(cint(Handle));
End;
Procedure Do_Erase(p:pchar);
var
fileinfo : stat;
Begin
{ verify if the filename is actually a directory }
{ if so return error and do nothing, as defined }
{ by POSIX }
if Fpstat(p,fileinfo)<0 then
begin
Errno2Inoutres;
exit;
end;
if FpS_ISDIR(fileinfo.st_mode) then
begin
InOutRes := 2;
exit;
end;
if Fpunlink(p)<0 then
Errno2Inoutres
Else
InOutRes:=0;
End;
{ truncate at a given position }
procedure do_truncate (handle:thandle;fpos:longint);
begin
{ should be simulated in cases where it is not }
{ available. }
If Fpftruncate(handle,fpos)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Procedure Do_Rename(p1,p2:pchar);
Begin
If Fprename(p1,p2)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_Write(Handle:thandle;Addr:Pointer;Len:SizeInt):SizeInt;
Begin
repeat
Do_Write:=Fpwrite(Handle,addr,len);
until (Do_Write>=0) or (getErrNo<>ESysEINTR);
If Do_Write<0 Then
Begin
Errno2InOutRes;
Do_Write:=0;
End
else
InOutRes:=0;
End;
Function Do_Read(Handle:thandle;Addr:Pointer;Len:SizeInt):SizeInt;
Begin
repeat
Do_Read:=Fpread(Handle,addr,len);
until (Do_Read>=0) or (getErrNo<>ESysEINTR);
If Do_Read<0 Then
Begin
Errno2InOutRes;
Do_Read:=0;
End
else
InOutRes:=0;
End;
function Do_FilePos(Handle: thandle):longint;
Begin
do_FilePos:=Fplseek(Handle, 0, SEEK_CUR);
If Do_FilePos<0 Then
Errno2InOutRes
else
InOutRes:=0;
End;
Procedure Do_Seek(Handle:thandle;Pos:Longint);
Begin
If Fplseek(Handle, pos, SEEK_SET)<0 Then
Errno2Inoutres
Else
InOutRes:=0;
End;
Function Do_SeekEnd(Handle:thandle): Longint;
begin
Do_SeekEnd:=Fplseek(Handle,0,SEEK_END);
If Do_SeekEnd<0 Then
Errno2Inoutres
Else
InOutRes:=0;
end;
Function Do_FileSize(Handle:thandle): Longint;
var
Info : Stat;
Ret : Longint;
Begin
Ret:=Fpfstat(handle,info);
If Ret=0 Then
Do_FileSize:=Info.st_size
else
Do_FileSize:=0;
If Ret<0 Then
Errno2InOutRes
Else
InOutRes:=0;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : cint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags :=O_RDONLY;
FileRec(f).mode:=fminput;
end;
1 : begin
oflags :=O_WRONLY;
FileRec(f).mode:=fmoutput;
end;
2 : begin
oflags :=O_RDWR;
FileRec(f).mode:=fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
if (FileRec(f).Handle<0) and
(getErrNo=ESysEROFS) and
((OFlags and O_RDWR)<>0) then
begin
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle:=Fpopen(p,oflags,MODE_OPEN);
end;
If Filerec(f).Handle<0 Then
Errno2Inoutres
else
InOutRes:=0;
End;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

15
rtl/linux/sysos.inc
View File

@ -77,11 +77,24 @@ function fpgetcwd(buf:pchar;_size:size_t):pchar; cdecl; external name 'getcwd';
{$I ossysc.inc} // base syscalls
{$I osmain.inc} // base wrappers *nix RTL (derivatives)
const
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
{ read/write search permission for everyone }
MODE_MKDIR = MODE_OPEN OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
{
$Log$
Revision 1.1 2005-02-06 11:20:52 peter
Revision 1.2 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.1 2005/02/06 11:20:52 peter
* threading in system unit
* removed systhrds unit

67
rtl/win32/Makefile
View File

@ -253,103 +253,103 @@ GRAPHDIR=$(INC)/graph
include $(WININC)/makefile.inc
WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES)))
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-go32v2)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-win32)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-os2)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-freebsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-beos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-netbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-sunos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-qnx)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-netware)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-openbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-wdosx)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-emx)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-watcom)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-netwlibc)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-freebsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-netbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-amiga)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-atari)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-openbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),m68k-palmos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),powerpc-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),powerpc-netbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),powerpc-macos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),powerpc-darwin)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),powerpc-morphos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),sparc-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),sparc-netbsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),sparc-sunos)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),x86_64-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),x86_64-freebsd)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),arm-linux)
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
override TARGET_UNITS+=$(SYSTEMUNIT) ctypes objpas macpas strings lineinfo heaptrc matrix windows winsock initc cmem dynlibs signals dos crt objects graph messages rtlconst sysconst sysutils typinfo math types strutils convutils dateutils varutils variants classes cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer video mouse keyboard comobj winsysut ole2 activex shellapi shlobj
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_LOADERS+=wprt0 wdllprt0 gprt0 wcygprt0
@ -1966,7 +1966,6 @@ wdllprt0$(OEXT) : wdllprt0.as
wcygprt0$(OEXT) : wcygprt0.as
$(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp win32.inc $(SYSDEPS)
$(COMPILER) -Us -Sg $(SYSTEMUNIT).pp
systhrds$(PPUEXT): systhrds.pp $(INC)/threadh.inc $(SYSTEMUNIT)$(PPUEXT) objpas$(PPUEXT)
objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\

4
rtl/win32/Makefile.fpc
View File

@ -7,7 +7,7 @@ main=rtl
[target]
loaders=wprt0 wdllprt0 gprt0 wcygprt0
units=$(SYSTEMUNIT) ctypes systhrds objpas macpas strings \
units=$(SYSTEMUNIT) ctypes objpas macpas strings \
lineinfo heaptrc matrix \
windows winsock initc cmem dynlibs signals \
dos crt objects graph messages \
@ -107,8 +107,6 @@ wcygprt0$(OEXT) : wcygprt0.as
$(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp win32.inc $(SYSDEPS)
$(COMPILER) -Us -Sg $(SYSTEMUNIT).pp
systhrds$(PPUEXT): systhrds.pp $(INC)/threadh.inc $(SYSTEMUNIT)$(PPUEXT) objpas$(PPUEXT)
objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp

15
rtl/win32/classes.pp
View File

@ -16,11 +16,6 @@
{$mode objfpc}
{ Require threading }
{$ifndef ver1_0}
{$threading on}
{$endif ver1_0}
{ determine the type of the resource/form file }
{$define Win16Res}
@ -48,20 +43,24 @@ uses
initialization
CommonInit;
{$ifndef ver1_0}
systhrds.InitCriticalSection(SynchronizeCritSect);
InitCriticalSection(SynchronizeCritSect);
ExecuteEvent := RtlEventCreate;
SynchronizeMethod := nil;
{$endif}
finalization
CommonCleanup;
{$ifndef ver1_0}
systhrds.DoneCriticalSection(SynchronizeCritSect);
DoneCriticalSection(SynchronizeCritSect);
RtlEventDestroy(ExecuteEvent);
{$endif}
end.
{
$Log$
Revision 1.6 2004-12-23 09:42:42 marco
Revision 1.7 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.6 2004/12/23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.5 2004/01/22 17:11:23 peter

104
rtl/win32/sysdir.inc Normal file
View File

@ -0,0 +1,104 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
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.
**********************************************************************}
{*****************************************************************************
Directory Handling
*****************************************************************************}
type
TDirFnType=function(name:pointer):longbool;stdcall;
procedure dirfn(afunc : TDirFnType;const s:string);
var
buffer : array[0..255] of char;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
AllowSlash(pchar(@buffer));
if not aFunc(@buffer) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function CreateDirectoryTrunc(name:pointer):longbool;stdcall;
begin
CreateDirectoryTrunc:=CreateDirectory(name,nil);
end;
procedure mkdir(const s:string);[IOCHECK];
begin
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@CreateDirectoryTrunc),s);
end;
procedure rmdir(const s:string);[IOCHECK];
begin
if (s ='.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@RemoveDirectory),s);
end;
procedure chdir(const s:string);[IOCHECK];
begin
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@SetCurrentDirectory),s);
if Inoutres=2 then
Inoutres:=3;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
const
Drive:array[0..3]of char=(#0,':',#0,#0);
var
defaultdrive:boolean;
DirBuf,SaveBuf:array[0..259] of Char;
begin
defaultdrive:=drivenr=0;
if not defaultdrive then
begin
byte(Drive[0]):=Drivenr+64;
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
if not SetCurrentDirectory(@Drive) then
begin
errno := word (GetLastError);
Errno2InoutRes;
Dir := char (DriveNr + 64) + ':\';
SetCurrentDirectory(@SaveBuf);
Exit;
end;
end;
GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
if not defaultdrive then
SetCurrentDirectory(@SaveBuf);
dir:=strpas(DirBuf);
if not FileNameCaseSensitive then
dir:=upcase(dir);
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

272
rtl/win32/sysfile.inc Normal file
View File

@ -0,0 +1,272 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
Low leve file functions
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.
**********************************************************************}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
procedure AllowSlash(p:pchar);
var
i : longint;
begin
{ allow slash as backslash }
for i:=0 to strlen(p) do
if p[i]='/' then p[i]:='\';
end;
function do_isdevice(handle:thandle):boolean;
begin
do_isdevice:=(getfiletype(handle)=2);
end;
procedure do_close(h : thandle);
begin
if do_isdevice(h) then
exit;
CloseHandle(h);
end;
procedure do_erase(p : pchar);
begin
AllowSlash(p);
if DeleteFile(p)=0 then
Begin
errno:=GetLastError;
if errno=5 then
begin
if (GetFileAttributes(p)=FILE_ATTRIBUTE_DIRECTORY) then
errno:=2;
end;
Errno2InoutRes;
end;
end;
procedure do_rename(p1,p2 : pchar);
begin
AllowSlash(p1);
AllowSlash(p2);
if MoveFile(p1,p2)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_write(h:thandle;addr:pointer;len : longint) : longint;
var
size:longint;
begin
if writefile(h,addr,len,size,nil)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
do_write:=size;
end;
function do_read(h:thandle;addr:pointer;len : longint) : longint;
var
_result:longint;
begin
if readfile(h,addr,len,_result,nil)=0 then
Begin
errno:=GetLastError;
if errno=ERROR_BROKEN_PIPE then
errno:=0
else
Errno2InoutRes;
end;
do_read:=_result;
end;
function do_filepos(handle : thandle) : longint;
var
l:longint;
begin
l:=SetFilePointer(handle,0,nil,FILE_CURRENT);
if l=-1 then
begin
l:=0;
errno:=GetLastError;
Errno2InoutRes;
end;
do_filepos:=l;
end;
procedure do_seek(handle:thandle;pos : longint);
begin
if SetFilePointer(handle,pos,nil,FILE_BEGIN)=-1 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_seekend(handle:thandle):longint;
begin
do_seekend:=SetFilePointer(handle,0,nil,FILE_END);
if do_seekend=-1 then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_filesize(handle : thandle) : longint;
var
aktfilepos : longint;
begin
aktfilepos:=do_filepos(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,aktfilepos);
end;
procedure do_truncate (handle:thandle;pos:longint);
begin
do_seek(handle,pos);
if not(SetEndOfFile(handle)) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
Const
file_Share_Read = $00000001;
file_Share_Write = $00000002;
Var
shflags,
oflags,cd : longint;
security : TSecurityAttributes;
begin
AllowSlash(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fmclosed : ;
else
begin
{not assigned}
inoutres:=102;
exit;
end;
end;
end;
{ reset file handle }
filerec(f).handle:=UnusedHandle;
{ convert filesharing }
shflags:=0;
if ((filemode and fmshareExclusive) = fmshareExclusive) then
{ no sharing }
else
if (filemode = fmShareCompat) or ((filemode and fmshareDenyWrite) = fmshareDenyWrite) then
shflags := file_Share_Read
else
if ((filemode and fmshareDenyRead) = fmshareDenyRead) then
shflags := file_Share_Write
else
if ((filemode and fmshareDenyNone) = fmshareDenyNone) then
shflags := file_Share_Read + file_Share_Write;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : begin
filerec(f).mode:=fminput;
oflags:=longint(GENERIC_READ);
end;
1 : begin
filerec(f).mode:=fmoutput;
oflags:=longint(GENERIC_WRITE);
end;
2 : begin
filerec(f).mode:=fminout;
oflags:=longint(GENERIC_WRITE or GENERIC_READ);
end;
end;
{ create it ? }
if (flags and $1000)<>0 then
cd:=CREATE_ALWAYS
{ or Append/Open ? }
else
cd:=OPEN_EXISTING;
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
security.nLength := Sizeof(TSecurityAttributes);
security.bInheritHandle:=true;
security.lpSecurityDescriptor:=nil;
filerec(f).handle:=CreateFile(p,oflags,shflags,@security,cd,FILE_ATTRIBUTE_NORMAL,0);
{ append mode }
if ((flags and $100)<>0) and
(filerec(f).handle<>0) and
(filerec(f).handle<>UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
{ get errors }
{ handle -1 is returned sometimes !! (PM) }
if (filerec(f).handle=0) or (filerec(f).handle=UnusedHandle) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

63
rtl/win32/sysheap.inc Normal file
View File

@ -0,0 +1,63 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{*****************************************************************************
OS Memory allocation / deallocation
****************************************************************************}
{ memory functions }
function GetProcessHeap : DWord;
stdcall;external 'kernel32' name 'GetProcessHeap';
function HeapAlloc(hHeap : DWord; dwFlags : DWord; dwBytes : DWord) : Longint;
stdcall;external 'kernel32' name 'HeapAlloc';
function HeapFree(hHeap : dword; dwFlags : dword; lpMem: pointer) : boolean;
stdcall;external 'kernel32' name 'HeapFree';
{$IFDEF SYSTEMDEBUG}
function WinAPIHeapSize(hHeap : DWord; dwFlags : DWord; ptr : Pointer) : DWord;
stdcall;external 'kernel32' name 'HeapSize';
{$ENDIF}
function SysOSAlloc(size: ptrint): pointer;
var
l : longword;
begin
l := HeapAlloc(GetProcessHeap, 0, size);
{$ifdef DUMPGROW}
Writeln('new heap part at $',hexstr(l,8), ' size = ',WinAPIHeapSize(GetProcessHeap()));
{$endif}
SysOSAlloc := pointer(l);
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint);
begin
HeapFree(GetProcessHeap, 0, p);
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

289
rtl/win32/sysos.inc Normal file
View File

@ -0,0 +1,289 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
const
{ constants for GetStdHandle }
STD_INPUT_HANDLE = longint($fffffff6);
STD_OUTPUT_HANDLE = longint($fffffff5);
STD_ERROR_HANDLE = longint($fffffff4);
INVALID_HANDLE_VALUE = longint($ffffffff);
IGNORE = 0; { Ignore signal }
INFINITE = longint($FFFFFFFF); { Infinite timeout }
{ flags for CreateFile }
GENERIC_READ=$80000000;
GENERIC_WRITE=$40000000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
FILE_ATTRIBUTE_ARCHIVE = 32;
FILE_ATTRIBUTE_COMPRESSED = 2048;
FILE_ATTRIBUTE_NORMAL = 128;
FILE_ATTRIBUTE_DIRECTORY = 16;
FILE_ATTRIBUTE_HIDDEN = 2;
FILE_ATTRIBUTE_READONLY = 1;
FILE_ATTRIBUTE_SYSTEM = 4;
FILE_ATTRIBUTE_TEMPORARY = 256;
{ Share mode open }
fmShareCompat = $00000000;
fmShareExclusive = $10;
fmShareDenyWrite = $20;
fmShareDenyRead = $30;
fmShareDenyNone = $40;
{ flags for SetFilePos }
FILE_BEGIN = 0;
FILE_CURRENT = 1;
FILE_END = 2;
{ GetFileType }
FILE_TYPE_UNKNOWN = 0;
FILE_TYPE_DISK = 1;
FILE_TYPE_CHAR = 2;
FILE_TYPE_PIPE = 3;
VER_PLATFORM_WIN32s = 0;
VER_PLATFORM_WIN32_WINDOWS = 1;
VER_PLATFORM_WIN32_NT = 2;
{ These constants are used for conversion of error codes }
{ from win32 i/o errors to tp i/o errors }
{ errors 1 to 18 are the same as in Turbo Pascal }
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING! }
{ The media is write protected. }
ERROR_WRITE_PROTECT = 19;
{ The system cannot find the device specified. }
ERROR_BAD_UNIT = 20;
{ The device is not ready. }
ERROR_NOT_READY = 21;
{ The device does not recognize the command. }
ERROR_BAD_COMMAND = 22;
{ Data error (cyclic redundancy check) }
ERROR_CRC = 23;
{ The program issued a command but the }
{ command length is incorrect. }
ERROR_BAD_LENGTH = 24;
{ The drive cannot locate a specific }
{ area or track on the disk. }
ERROR_SEEK = 25;
{ The specified disk or diskette cannot be accessed. }
ERROR_NOT_DOS_DISK = 26;
{ The drive cannot find the sector requested. }
ERROR_SECTOR_NOT_FOUND = 27;
{ The printer is out of paper. }
ERROR_OUT_OF_PAPER = 28;
{ The system cannot write to the specified device. }
ERROR_WRITE_FAULT = 29;
{ The system cannot read from the specified device. }
ERROR_READ_FAULT = 30;
{ A device attached to the system is not functioning.}
ERROR_GEN_FAILURE = 31;
{ The process cannot access the file because }
{ it is being used by another process. }
ERROR_SHARING_VIOLATION = 32;
{ A pipe has been closed on the other end }
{ Removing that error allows eof to works as on other OSes }
ERROR_BROKEN_PIPE = 109;
ERROR_DIR_NOT_EMPTY = 145;
ERROR_ALREADY_EXISTS = 183;
type
{UINT = longint;
BOOL = longint; obsolete }
UINT = cardinal;
BOOL = longbool;
// WCHAR = word;
{$ifdef UNICODE}
LPTCH = ^word;
LPTSTR = ^word;
LPCTSTR = ^word;
{$else UNICODE}
LPTCH = ^char;
LPTSTR = ^char;
LPCTSTR = ^char;
{$endif UNICODE}
LPWSTR = ^wchar;
PVOID = pointer;
LPVOID = pointer;
LPCVOID = pointer;
LPDWORD = ^DWORD;
HLocal = THandle;
PStr = pchar;
LPStr = pchar;
PLPSTR = ^LPSTR;
PLPWSTR = ^LPWSTR;
PSecurityAttributes = ^TSecurityAttributes;
TSecurityAttributes = packed record
nLength : DWORD;
lpSecurityDescriptor : Pointer;
bInheritHandle : BOOL;
end;
PProcessInformation = ^TProcessInformation;
TProcessInformation = record
hProcess: THandle;
hThread: THandle;
dwProcessId: DWORD;
dwThreadId: DWORD;
end;
PFileTime = ^TFileTime;
TFileTime = record
dwLowDateTime,
dwHighDateTime : DWORD;
end;
LPSystemTime= ^PSystemTime;
PSystemTime = ^TSystemTime;
TSystemTime = record
wYear,
wMonth,
wDayOfWeek,
wDay,
wHour,
wMinute,
wSecond,
wMilliseconds: Word;
end;
{$IFDEF SUPPORT_THREADVAR}
threadvar
{$ELSE SUPPORT_THREADVAR}
var
{$ENDIF SUPPORT_THREADVAR}
errno : longint;
{$ASMMODE ATT}
{ misc. functions }
function GetLastError : DWORD;
stdcall;external 'kernel32' name 'GetLastError';
{ time and date functions }
function GetTickCount : longint;
stdcall;external 'kernel32' name 'GetTickCount';
{ process functions }
procedure ExitProcess(uExitCode : UINT);
stdcall;external 'kernel32' name 'ExitProcess';
{ Startup }
procedure GetStartupInfo(p : pointer);
stdcall;external 'kernel32' name 'GetStartupInfoA';
function GetStdHandle(nStdHandle:DWORD):THANDLE;
stdcall;external 'kernel32' name 'GetStdHandle';
{ command line/enviroment functions }
function GetCommandLine : pchar;
stdcall;external 'kernel32' name 'GetCommandLineA';
function GetCurrentProcessId:DWORD;
stdcall; external 'kernel32' name 'GetCurrentProcessId';
function Win32GetCurrentThreadId:DWORD;
stdcall; external 'kernel32' name 'GetCurrentThreadId';
{ module functions }
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
stdcall;external 'kernel32' name 'GetModuleFileNameA';
function GetModuleHandle(p : pointer) : longint;
stdcall;external 'kernel32' name 'GetModuleHandleA';
function GetCommandFile:pchar;forward;
{ file functions }
function WriteFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
stdcall;external 'kernel32' name 'WriteFile';
function ReadFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
stdcall;external 'kernel32' name 'ReadFile';
function CloseHandle(h : thandle) : longint;
stdcall;external 'kernel32' name 'CloseHandle';
function DeleteFile(p : pchar) : longint;
stdcall;external 'kernel32' name 'DeleteFileA';
function MoveFile(old,_new : pchar) : longint;
stdcall;external 'kernel32' name 'MoveFileA';
function SetFilePointer(l1,l2 : thandle;l3 : pointer;l4 : longint) : longint;
stdcall;external 'kernel32' name 'SetFilePointer';
function GetFileSize(h:thandle;p:pointer) : longint;
stdcall;external 'kernel32' name 'GetFileSize';
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
stdcall;external 'kernel32' name 'CreateFileA';
function SetEndOfFile(h : thandle) : longbool;
stdcall;external 'kernel32' name 'SetEndOfFile';
function GetFileType(Handle:thandle):DWord;
stdcall;external 'kernel32' name 'GetFileType';
function GetFileAttributes(p : pchar) : dword;
stdcall;external 'kernel32' name 'GetFileAttributesA';
{ Directory }
function CreateDirectory(name : pointer;sec : pointer) : longbool;
stdcall;external 'kernel32' name 'CreateDirectoryA';
function RemoveDirectory(name:pointer):longbool;
stdcall;external 'kernel32' name 'RemoveDirectoryA';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external 'kernel32' name 'SetCurrentDirectoryA';
function GetCurrentDirectory(bufsize : longint;name : pchar) : longbool;
stdcall;external 'kernel32' name 'GetCurrentDirectoryA';
Procedure Errno2InOutRes;
Begin
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
case Errno of
ERROR_WRITE_PROTECT..ERROR_GEN_FAILURE :
begin
{ This is the offset to the Win32 to add to directly map }
{ to the DOS/TP compatible error codes when in this range }
InOutRes := word(errno)+131;
end;
ERROR_DIR_NOT_EMPTY,
ERROR_ALREADY_EXISTS,
ERROR_SHARING_VIOLATION :
begin
InOutRes :=5;
end;
else
begin
{ other error codes can directly be mapped }
InOutRes := Word(errno);
end;
end;
errno:=0;
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

47
rtl/win32/sysosh.inc Normal file
View File

@ -0,0 +1,47 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{Platform specific information}
type
{$ifdef CPU64}
THandle = QWord;
{$else CPU64}
THandle = DWord;
{$endif CPU64}
{ the fields of this record are os dependent }
{ and they shouldn't be used in a program }
{ only the type TCriticalSection is important }
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
DebugInfo : pointer;
LockCount : longint;
RecursionCount : longint;
OwningThread : DWord;
LockSemaphore : DWord;
Reserved : DWord;
end;
{
$Log$
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

613
rtl/win32/system.pp
View File

@ -28,17 +28,12 @@ interface
{$define Set_i386_Exception_handler}
{$endif cpui386}
{ Ctrl-Z means EOF }
{$DEFINE EOF_CTRLZ}
{ include system-independent routine headers }
{$I systemh.inc}
{Platform specific information}
type
{$ifdef CPU64}
THandle = QWord;
{$else CPU64}
THandle = DWord;
{$endif CPU64}
const
LineEnding = #13#10;
LFNSupport = true;
@ -55,9 +50,6 @@ type
handler : pointer;
end;
{ include heap support headers }
{$I heaph.inc}
const
{ Default filehandles }
UnusedHandle : THandle = -1;
@ -127,577 +119,9 @@ implementation
{ include system independent routines }
{$I system.inc}
{ some declarations for Win32 API calls }
{$I win32.inc}
CONST
{ These constants are used for conversion of error codes }
{ from win32 i/o errors to tp i/o errors }
{ errors 1 to 18 are the same as in Turbo Pascal }
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING! }
{ The media is write protected. }
ERROR_WRITE_PROTECT = 19;
{ The system cannot find the device specified. }
ERROR_BAD_UNIT = 20;
{ The device is not ready. }
ERROR_NOT_READY = 21;
{ The device does not recognize the command. }
ERROR_BAD_COMMAND = 22;
{ Data error (cyclic redundancy check) }
ERROR_CRC = 23;
{ The program issued a command but the }
{ command length is incorrect. }
ERROR_BAD_LENGTH = 24;
{ The drive cannot locate a specific }
{ area or track on the disk. }
ERROR_SEEK = 25;
{ The specified disk or diskette cannot be accessed. }
ERROR_NOT_DOS_DISK = 26;
{ The drive cannot find the sector requested. }
ERROR_SECTOR_NOT_FOUND = 27;
{ The printer is out of paper. }
ERROR_OUT_OF_PAPER = 28;
{ The system cannot write to the specified device. }
ERROR_WRITE_FAULT = 29;
{ The system cannot read from the specified device. }
ERROR_READ_FAULT = 30;
{ A device attached to the system is not functioning.}
ERROR_GEN_FAILURE = 31;
{ The process cannot access the file because }
{ it is being used by another process. }
ERROR_SHARING_VIOLATION = 32;
{ A pipe has been closed on the other end }
{ Removing that error allows eof to works as on other OSes }
ERROR_BROKEN_PIPE = 109;
ERROR_DIR_NOT_EMPTY = 145;
ERROR_ALREADY_EXISTS = 183;
{$IFDEF SUPPORT_THREADVAR}
threadvar
{$ELSE SUPPORT_THREADVAR}
var
{$ENDIF SUPPORT_THREADVAR}
errno : longint;
{$ASMMODE ATT}
{ misc. functions }
function GetLastError : DWORD;
stdcall;external 'kernel32' name 'GetLastError';
{ time and date functions }
function GetTickCount : longint;
stdcall;external 'kernel32' name 'GetTickCount';
{ process functions }
procedure ExitProcess(uExitCode : UINT);
stdcall;external 'kernel32' name 'ExitProcess';
Procedure Errno2InOutRes;
Begin
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
case Errno of
ERROR_WRITE_PROTECT..ERROR_GEN_FAILURE :
begin
{ This is the offset to the Win32 to add to directly map }
{ to the DOS/TP compatible error codes when in this range }
InOutRes := word(errno)+131;
end;
ERROR_DIR_NOT_EMPTY,
ERROR_ALREADY_EXISTS,
ERROR_SHARING_VIOLATION :
begin
InOutRes :=5;
end;
else
begin
{ other error codes can directly be mapped }
InOutRes := Word(errno);
end;
end;
errno:=0;
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
{ module functions }
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
stdcall;external 'kernel32' name 'GetModuleFileNameA';
function GetModuleHandle(p : pointer) : longint;
stdcall;external 'kernel32' name 'GetModuleHandleA';
function GetCommandFile:pchar;forward;
function paramstr(l : longint) : string;
begin
if (l>=0) and (l<argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure randomize;
begin
randseed:=GetTickCount;
end;
{*****************************************************************************
Heap Management
Parameter Handling
*****************************************************************************}
{ memory functions }
function GetProcessHeap : DWord;
stdcall;external 'kernel32' name 'GetProcessHeap';
function HeapAlloc(hHeap : DWord; dwFlags : DWord; dwBytes : DWord) : Longint;
stdcall;external 'kernel32' name 'HeapAlloc';
function HeapFree(hHeap : dword; dwFlags : dword; lpMem: pointer) : boolean;
stdcall;external 'kernel32' name 'HeapFree';
{$IFDEF SYSTEMDEBUG}
function WinAPIHeapSize(hHeap : DWord; dwFlags : DWord; ptr : Pointer) : DWord;
stdcall;external 'kernel32' name 'HeapSize';
{$ENDIF}
{*****************************************************************************
OS Memory allocation / deallocation
****************************************************************************}
function SysOSAlloc(size: ptrint): pointer;
var
l : longword;
begin
l := HeapAlloc(GetProcessHeap, 0, size);
{$ifdef DUMPGROW}
Writeln('new heap part at $',hexstr(l,8), ' size = ',WinAPIHeapSize(GetProcessHeap()));
{$endif}
SysOSAlloc := pointer(l);
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint);
begin
HeapFree(GetProcessHeap, 0, p);
end;
{ include standard heap management }
{$I heap.inc}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
function WriteFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
stdcall;external 'kernel32' name 'WriteFile';
function ReadFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
overlap:pointer):longint;
stdcall;external 'kernel32' name 'ReadFile';
function CloseHandle(h : thandle) : longint;
stdcall;external 'kernel32' name 'CloseHandle';
function DeleteFile(p : pchar) : longint;
stdcall;external 'kernel32' name 'DeleteFileA';
function MoveFile(old,_new : pchar) : longint;
stdcall;external 'kernel32' name 'MoveFileA';
function SetFilePointer(l1,l2 : thandle;l3 : pointer;l4 : longint) : longint;
stdcall;external 'kernel32' name 'SetFilePointer';
function GetFileSize(h:thandle;p:pointer) : longint;
stdcall;external 'kernel32' name 'GetFileSize';
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
stdcall;external 'kernel32' name 'CreateFileA';
function SetEndOfFile(h : thandle) : longbool;
stdcall;external 'kernel32' name 'SetEndOfFile';
function GetFileType(Handle:thandle):DWord;
stdcall;external 'kernel32' name 'GetFileType';
function GetFileAttributes(p : pchar) : dword;
stdcall;external 'kernel32' name 'GetFileAttributesA';
procedure AllowSlash(p:pchar);
var
i : longint;
begin
{ allow slash as backslash }
for i:=0 to strlen(p) do
if p[i]='/' then p[i]:='\';
end;
function do_isdevice(handle:thandle):boolean;
begin
do_isdevice:=(getfiletype(handle)=2);
end;
procedure do_close(h : thandle);
begin
if do_isdevice(h) then
exit;
CloseHandle(h);
end;
procedure do_erase(p : pchar);
begin
AllowSlash(p);
if DeleteFile(p)=0 then
Begin
errno:=GetLastError;
if errno=5 then
begin
if (GetFileAttributes(p)=FILE_ATTRIBUTE_DIRECTORY) then
errno:=2;
end;
Errno2InoutRes;
end;
end;
procedure do_rename(p1,p2 : pchar);
begin
AllowSlash(p1);
AllowSlash(p2);
if MoveFile(p1,p2)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_write(h:thandle;addr:pointer;len : longint) : longint;
var
size:longint;
begin
if writefile(h,addr,len,size,nil)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
do_write:=size;
end;
function do_read(h:thandle;addr:pointer;len : longint) : longint;
var
_result:longint;
begin
if readfile(h,addr,len,_result,nil)=0 then
Begin
errno:=GetLastError;
if errno=ERROR_BROKEN_PIPE then
errno:=0
else
Errno2InoutRes;
end;
do_read:=_result;
end;
function do_filepos(handle : thandle) : longint;
var
l:longint;
begin
l:=SetFilePointer(handle,0,nil,FILE_CURRENT);
if l=-1 then
begin
l:=0;
errno:=GetLastError;
Errno2InoutRes;
end;
do_filepos:=l;
end;
procedure do_seek(handle:thandle;pos : longint);
begin
if SetFilePointer(handle,pos,nil,FILE_BEGIN)=-1 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_seekend(handle:thandle):longint;
begin
do_seekend:=SetFilePointer(handle,0,nil,FILE_END);
if do_seekend=-1 then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function do_filesize(handle : thandle) : longint;
var
aktfilepos : longint;
begin
aktfilepos:=do_filepos(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,aktfilepos);
end;
procedure do_truncate (handle:thandle;pos:longint);
begin
do_seek(handle,pos);
if not(SetEndOfFile(handle)) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
Const
file_Share_Read = $00000001;
file_Share_Write = $00000002;
Var
shflags,
oflags,cd : longint;
security : TSecurityAttributes;
begin
AllowSlash(p);
{ close first if opened }
if ((flags and $10000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fmclosed : ;
else
begin
{not assigned}
inoutres:=102;
exit;
end;
end;
end;
{ reset file handle }
filerec(f).handle:=UnusedHandle;
{ convert filesharing }
shflags:=0;
if ((filemode and fmshareExclusive) = fmshareExclusive) then
{ no sharing }
else
if (filemode = fmShareCompat) or ((filemode and fmshareDenyWrite) = fmshareDenyWrite) then
shflags := file_Share_Read
else
if ((filemode and fmshareDenyRead) = fmshareDenyRead) then
shflags := file_Share_Write
else
if ((filemode and fmshareDenyNone) = fmshareDenyNone) then
shflags := file_Share_Read + file_Share_Write;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : begin
filerec(f).mode:=fminput;
oflags:=longint(GENERIC_READ);
end;
1 : begin
filerec(f).mode:=fmoutput;
oflags:=longint(GENERIC_WRITE);
end;
2 : begin
filerec(f).mode:=fminout;
oflags:=longint(GENERIC_WRITE or GENERIC_READ);
end;
end;
{ create it ? }
if (flags and $1000)<>0 then
cd:=CREATE_ALWAYS
{ or Append/Open ? }
else
cd:=OPEN_EXISTING;
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
security.nLength := Sizeof(TSecurityAttributes);
security.bInheritHandle:=true;
security.lpSecurityDescriptor:=nil;
filerec(f).handle:=CreateFile(p,oflags,shflags,@security,cd,FILE_ATTRIBUTE_NORMAL,0);
{ append mode }
if ((flags and $100)<>0) and
(filerec(f).handle<>0) and
(filerec(f).handle<>UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
{ get errors }
{ handle -1 is returned sometimes !! (PM) }
if (filerec(f).handle=0) or (filerec(f).handle=UnusedHandle) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
{*****************************************************************************
UnTyped File Handling
*****************************************************************************}
{$i file.inc}
{*****************************************************************************
Typed File Handling
*****************************************************************************}
{$i typefile.inc}
{*****************************************************************************
Text File Handling
*****************************************************************************}
{$DEFINE EOF_CTRLZ}
{$i text.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
function CreateDirectory(name : pointer;sec : pointer) : longbool;
stdcall;external 'kernel32' name 'CreateDirectoryA';
function RemoveDirectory(name:pointer):longbool;
stdcall;external 'kernel32' name 'RemoveDirectoryA';
function SetCurrentDirectory(name : pointer) : longbool;
stdcall;external 'kernel32' name 'SetCurrentDirectoryA';
function GetCurrentDirectory(bufsize : longint;name : pchar) : longbool;
stdcall;external 'kernel32' name 'GetCurrentDirectoryA';
type
TDirFnType=function(name:pointer):longbool;stdcall;
procedure dirfn(afunc : TDirFnType;const s:string);
var
buffer : array[0..255] of char;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
AllowSlash(pchar(@buffer));
if not aFunc(@buffer) then
begin
errno:=GetLastError;
Errno2InoutRes;
end;
end;
function CreateDirectoryTrunc(name:pointer):longbool;stdcall;
begin
CreateDirectoryTrunc:=CreateDirectory(name,nil);
end;
procedure mkdir(const s:string);[IOCHECK];
begin
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@CreateDirectoryTrunc),s);
end;
procedure rmdir(const s:string);[IOCHECK];
begin
if (s ='.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@RemoveDirectory),s);
end;
procedure chdir(const s:string);[IOCHECK];
begin
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@SetCurrentDirectory),s);
if Inoutres=2 then
Inoutres:=3;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
const
Drive:array[0..3]of char=(#0,':',#0,#0);
var
defaultdrive:boolean;
DirBuf,SaveBuf:array[0..259] of Char;
begin
defaultdrive:=drivenr=0;
if not defaultdrive then
begin
byte(Drive[0]):=Drivenr+64;
GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
if not SetCurrentDirectory(@Drive) then
begin
errno := word (GetLastError);
Errno2InoutRes;
Dir := char (DriveNr + 64) + ':\';
SetCurrentDirectory(@SaveBuf);
Exit;
end;
end;
GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
if not defaultdrive then
SetCurrentDirectory(@SaveBuf);
dir:=strpas(DirBuf);
if not FileNameCaseSensitive then
dir:=upcase(dir);
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
{ Startup }
procedure GetStartupInfo(p : pointer);
stdcall;external 'kernel32' name 'GetStartupInfoA';
function GetStdHandle(nStdHandle:DWORD):THANDLE;
stdcall;external 'kernel32' name 'GetStdHandle';
{ command line/enviroment functions }
function GetCommandLine : pchar;
stdcall;external 'kernel32' name 'GetCommandLineA';
function GetCurrentProcessId:DWORD;
stdcall; external 'kernel32' name 'GetCurrentProcessId';
function GetCurrentThreadId:DWORD;
stdcall; external 'kernel32' name 'GetCurrentThreadId';
var
ModuleName : array[0..255] of char;
@ -895,6 +319,26 @@ begin
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
if (l>=0) and (l<argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure randomize;
begin
randseed:=GetTickCount;
end;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
@ -1608,7 +1052,8 @@ begin
{ Reset IO Error }
InOutRes:=0;
ProcessID := GetCurrentProcessID;
ThreadID := GetCurrentThreadID;
{ threading }
InitSystemThreads;
{ Reset internal error variable }
errno:=0;
{$ifdef HASVARIANT}
@ -1621,7 +1066,11 @@ end.
{
$Log$
Revision 1.66 2005-02-01 20:22:50 florian
Revision 1.67 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.66 2005/02/01 20:22:50 florian
* improved widestring infrastructure manager
Revision 1.65 2004/12/12 11:53:47 florian

112
rtl/win32/systhrds.pp → rtl/win32/systhrd.inc
View File

@ -4,7 +4,7 @@
Copyright (c) 2002 by Peter Vreman,
member of the Free Pascal development team.
Win32 threading support implementation
Linux (pthreads) threading support implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -14,40 +14,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
unit systhrds;
interface
{$S-}
type
{ the fields of this record are os dependent }
{ and they shouldn't be used in a program }
{ only the type TCriticalSection is important }
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
DebugInfo : pointer;
LockCount : longint;
RecursionCount : longint;
OwningThread : DWord;
LockSemaphore : DWord;
Reserved : DWord;
end;
{ Include generic thread interface }
{$i threadh.inc}
implementation
function SysGetCurrentThreadId : dword;forward;
{*****************************************************************************
Generic overloaded
*****************************************************************************}
{ Include generic overloaded routines }
{$i thread.inc}
{*****************************************************************************
Local WINApi imports
@ -79,13 +46,11 @@ procedure Sleep(dwMilliseconds: DWord); stdcall;external 'kernel32' name 'Sleep'
function WinSuspendThread (threadHandle : dword) : dword; stdcall;external 'kernel32' name 'SuspendThread';
function WinResumeThread (threadHandle : dword) : dword; stdcall;external 'kernel32' name 'ResumeThread';
function TerminateThread (threadHandle : dword; var exitCode : dword) : boolean; stdcall;external 'kernel32' name 'TerminateThread';
function GetLastError : dword; stdcall;external 'kernel32' name 'GetLastError';
function WaitForSingleObject (hHandle,Milliseconds: dword): dword; stdcall;external 'kernel32' name 'WaitForSingleObject';
function WinThreadSetPriority (threadHandle : dword; Prio: longint): boolean; stdcall;external 'kernel32' name 'SetThreadPriority';
function WinThreadGetPriority (threadHandle : dword): Integer; stdcall;external 'kernel32' name 'GetThreadPriority';
function WinThreadGetPriority (threadHandle : dword): LongInt; stdcall;external 'kernel32' name 'GetThreadPriority';
function WinGetCurrentThreadId : dword; stdcall;external 'kernel32' name 'GetCurrentThread';
function CreateEvent(lpEventAttributes:pointer;bManualReset:longbool;bInitialState:longbool;lpName:pchar):CARDINAL; stdcall; external 'kernel32' name 'CreateEventA';
function CloseHandle(hObject:CARDINAL):LONGBOOL; stdcall; external 'kernel32' name 'CloseHandle';
function ResetEvent(hEvent:CARDINAL):LONGBOOL; stdcall; external 'kernel32' name 'ResetEvent';
function SetEvent(hEvent:CARDINAL):LONGBOOL; stdcall; external 'kernel32' name 'SetEvent';
function PulseEvent(hEvent:THANDLE):CARDINAL {WINBOOL}; stdcall; external 'kernel32' name 'PulseEvent';
@ -142,9 +107,6 @@ CONST
GlobalFree(TlsGetValue(tlskey));
end;
{ Include OS independent Threadvar initialization }
{$i threadvr.inc}
{$endif HASTHREADVAR}
@ -169,7 +131,7 @@ CONST
end;
function ThreadMain(param : pointer) : integer; stdcall;
function ThreadMain(param : pointer) : Longint; stdcall;
var
ti : tthreadinfo;
begin
@ -274,14 +236,14 @@ CONST
end;
function SysThreadGetPriority (threadHandle : dword): Integer;
function SysThreadGetPriority (threadHandle : dword): longint;
begin
SysThreadGetPriority:=WinThreadGetPriority(threadHandle);
end;
function SysGetCurrentThreadId : dword;
begin
SysGetCurrentThreadId:=WinGetCurrentThreadId;
SysGetCurrentThreadId:=Win32GetCurrentThreadId;
end;
{*****************************************************************************
@ -435,14 +397,14 @@ begin
PulseEvent(THANDLE(AEvent));
end;
CONST INFINITE=-1;
procedure intRTLEventStartWait(AEvent: PRTLEvent);
begin
// nothing to do, win32 events stay signalled after being set
end;
procedure intRTLEventWaitFor(AEvent: PRTLEvent);
CONST
INFINITE=-1;
begin
WaitForSingleObject(THANDLE(AEvent), INFINITE);
end;
@ -452,8 +414,7 @@ end;
Var
WinThreadManager : TThreadManager;
Procedure SetWinThreadManager;
Procedure InitSystemThreads;
begin
With WinThreadManager do
begin
@ -492,64 +453,15 @@ begin
end;
SetThreadManager(WinThreadManager);
InitHeapMutexes;
ThreadID := GetCurrentThreadID;
end;
initialization
SetWinThreadManager;
end.
{
$Log$
Revision 1.15 2005-01-30 21:48:14 marco
* stdcall added to few calls
Revision 1.14 2004/12/28 14:20:03 marco
* tthread patch from neli
Revision 1.13 2004/12/26 13:46:45 peter
* tthread uses systhrds
Revision 1.12 2004/12/22 21:29:24 marco
* rtlevent kraam. Checked (compile): Linux, FreeBSD, Darwin, Windows
Check work: ask Neli.
Revision 1.11 2004/05/23 15:30:13 marco
* first try
Revision 1.10 2004/01/21 14:15:42 florian
* fixed win32 compilation
Revision 1.9 2003/11/29 17:34:53 michael
+ Removed dummy variable from SetCthreadManager
Revision 1.8 2003/11/27 10:28:41 michael
+ Patch from peter to fix make cycle
Revision 1.7 2003/11/26 20:10:59 michael
+ New threadmanager implementation
Revision 1.6 2003/10/01 21:00:09 peter
* GetCurrentThreadHandle renamed to GetCurrentThreadId
Revision 1.5 2003/09/17 15:06:36 peter
* stdcall patch
Revision 1.4 2003/03/27 17:14:27 armin
* more platform independent thread routines, needs to be implemented for unix
Revision 1.3 2003/03/24 16:12:01 jonas
* BeginThread() now returns the thread handle instead of the threadid
(needed because you have to free the handle after your thread is
finished, and the threadid is already returned via a var-parameter)
Revision 1.2 2002/10/31 13:45:44 carl
* threadvar.inc -> threadvr.inc
Revision 1.1 2002/10/16 06:27:30 michael
+ Renamed thread unit to systhrds
Revision 1.1 2002/10/14 19:39:18 peter
* threads unit added for thread support
Revision 1.1 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
}

12
rtl/win32/tthread.inc
View File

@ -20,7 +20,7 @@ var
}
ExecuteEvent: PRtlEvent;
{ guard for synchronization variables }
SynchronizeCritSect: systhrds.TRtlCriticalSection;
SynchronizeCritSect: TRtlCriticalSection;
{ method to execute }
SynchronizeMethod: TThreadMethod;
{ caught exception in gui thread, to be raised in calling thread }
@ -201,7 +201,7 @@ begin
{ raise some error? }
exit;
systhrds.EnterCriticalSection(SynchronizeCritSect);
EnterCriticalSection(SynchronizeCritSect);
SynchronizeMethod := Method;
SynchronizeException := nil;
SynchronizeMethodProc;
@ -209,7 +209,7 @@ begin
RtlEventWaitFor(ExecuteEvent);
SynchronizeMethod := nil;
LocalSyncException := SynchronizeException;
systhrds.LeaveCriticalSection(SynchronizeCritSect);
LeaveCriticalSection(SynchronizeCritSect);
if LocalSyncException <> nil then
raise LocalSyncException;
end;
@ -265,7 +265,11 @@ begin
end;
{
$Log$
Revision 1.4 2004-12-26 13:46:45 peter
Revision 1.5 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.4 2004/12/26 13:46:45 peter
* tthread uses systhrds
Revision 1.3 2004/12/23 09:42:42 marco

114
rtl/win32/win32.inc
View File

@ -14,118 +14,14 @@
**********************************************************************}
const
{ constants for GetStdHandle }
STD_INPUT_HANDLE = longint($fffffff6);
STD_OUTPUT_HANDLE = longint($fffffff5);
STD_ERROR_HANDLE = longint($fffffff4);
INVALID_HANDLE_VALUE = longint($ffffffff);
IGNORE = 0; { Ignore signal }
INFINITE = longint($FFFFFFFF); { Infinite timeout }
{ flags for CreateFile }
GENERIC_READ=$80000000;
GENERIC_WRITE=$40000000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
FILE_ATTRIBUTE_ARCHIVE = 32;
FILE_ATTRIBUTE_COMPRESSED = 2048;
FILE_ATTRIBUTE_NORMAL = 128;
FILE_ATTRIBUTE_DIRECTORY = 16;
FILE_ATTRIBUTE_HIDDEN = 2;
FILE_ATTRIBUTE_READONLY = 1;
FILE_ATTRIBUTE_SYSTEM = 4;
FILE_ATTRIBUTE_TEMPORARY = 256;
{ Share mode open }
fmShareCompat = $00000000;
fmShareExclusive = $10;
fmShareDenyWrite = $20;
fmShareDenyRead = $30;
fmShareDenyNone = $40;
{ flags for SetFilePos }
FILE_BEGIN = 0;
FILE_CURRENT = 1;
FILE_END = 2;
{ GetFileType }
FILE_TYPE_UNKNOWN = 0;
FILE_TYPE_DISK = 1;
FILE_TYPE_CHAR = 2;
FILE_TYPE_PIPE = 3;
VER_PLATFORM_WIN32s = 0;
VER_PLATFORM_WIN32_WINDOWS = 1;
VER_PLATFORM_WIN32_NT = 2;
type
{UINT = longint;
BOOL = longint; obsolete }
UINT = cardinal;
BOOL = longbool;
// WCHAR = word;
{$ifdef UNICODE}
LPTCH = ^word;
LPTSTR = ^word;
LPCTSTR = ^word;
{$else UNICODE}
LPTCH = ^char;
LPTSTR = ^char;
LPCTSTR = ^char;
{$endif UNICODE}
LPWSTR = ^wchar;
PVOID = pointer;
LPVOID = pointer;
LPCVOID = pointer;
LPDWORD = ^DWORD;
HLocal = THandle;
PStr = pchar;
LPStr = pchar;
PLPSTR = ^LPSTR;
PLPWSTR = ^LPWSTR;
PSecurityAttributes = ^TSecurityAttributes;
TSecurityAttributes = packed record
nLength : DWORD;
lpSecurityDescriptor : Pointer;
bInheritHandle : BOOL;
end;
PProcessInformation = ^TProcessInformation;
TProcessInformation = record
hProcess: THandle;
hThread: THandle;
dwProcessId: DWORD;
dwThreadId: DWORD;
end;
PFileTime = ^TFileTime;
TFileTime = record
dwLowDateTime,
dwHighDateTime : DWORD;
end;
LPSystemTime= ^PSystemTime;
PSystemTime = ^TSystemTime;
TSystemTime = record
wYear,
wMonth,
wDayOfWeek,
wDay,
wHour,
wMinute,
wSecond,
wMilliseconds: Word;
end;
{
$Log$
Revision 1.10 2003-10-06 23:52:53 florian
Revision 1.11 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.10 2003/10/06 23:52:53 florian
* some data types cleaned up
Revision 1.9 2002/09/07 16:01:29 peter

9
rtl/win32/wininc/redef.inc
View File

@ -17,9 +17,6 @@
{$ifdef read_interface}
type
TRTLCriticalSection = CRITICAL_SECTION;
PRTLCriticalSection = PCRITICAL_SECTION;
PIID = PGUID;
TIID = TGUID;
THANDLE = HANDLE;
@ -1061,7 +1058,11 @@ end;
{
$Log$
Revision 1.29 2005-01-15 11:44:48 marco
Revision 1.30 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.29 2005/01/15 11:44:48 marco
* scrollwindow(ex) added at Neli's request
Revision 1.28 2004/12/18 20:00:59 michael

26
rtl/win32/wininc/struct.inc
View File

@ -1206,19 +1206,13 @@
TCRITICALSECTIONDEBUG = CRITICAL_SECTION_DEBUG;
PCRITICALSECTIONDEBUG = ^CRITICAL_SECTION_DEBUG;
CRITICAL_SECTION = record
DebugInfo : PCRITICAL_SECTION_DEBUG;
LockCount : LONG;
RecursionCount : LONG;
OwningThread : HANDLE;
LockSemaphore : HANDLE;
Reserved : DWORD;
end;
LPCRITICAL_SECTION = ^CRITICAL_SECTION;
PCRITICAL_SECTION = ^CRITICAL_SECTION;
_CRITICAL_SECTION = CRITICAL_SECTION;
TCRITICALSECTION = CRITICAL_SECTION;
PCRITICALSECTION = ^CRITICAL_SECTION;
CRITICAL_SECTION = TRTLCriticalSection;
_CRITICAL_SECTION = TRTLCriticalSection;
TCRITICAL_SECTION = TRTLCriticalSection;
PCRITICAL_SECTION = PRTLCriticalSection;
LPCRITICAL_SECTION = PRTLCriticalSection;
TCRITICALSECTION = TRTLCriticalSection;
PCRITICALSECTION = PRTLCriticalSection;
{ SECURITY_CONTEXT_TRACKING_MODE ContextTrackingMode; }
@ -7197,7 +7191,11 @@ type
{
$Log$
Revision 1.33 2005-02-03 18:41:12 florian
Revision 1.34 2005-02-06 13:06:20 peter
* moved file and dir functions to sysfile/sysdir
* win32 thread in systemunit
Revision 1.33 2005/02/03 18:41:12 florian
* more clx compilation fixed
Revision 1.32 2005/01/19 14:24:46 marco