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

Merge first batch of package handling related revisions from the packages branch

Browse Source 
Merged revision(s) 28796, 28837-28845, 28847-28850, 28852, 32135 from branches/svenbarth/packages:
Provide possibility to pass packages and search paths for packages as parameters.

fpkg.pas:
  + new unit which contains the base types related to package files (most importantly "tpackage")
globals.pas:
  + new variable "packagesearchpath" which contains all paths in which package files should be looked for
  + new variable "packagelist" which contains a list of all packages that should be used in a program or library
  * InitGlobals & DoneGlobals: initialize/finalize "packagesearchpath" accordingly ("packagelist" is handled in unit fpkg using a init/done-callback)
options.pas:
  + TOption: new fields "parapackagepath" and "parapackages" to keep track of package search paths and package files passed as parameters
  * TOption.interpret_option: use '-Fp' for package search paths and '-FP' for package files
  * read_arguments: apply the passed package search paths and packages to their respective containers
........
+ add a new unit which will contain basic functions related to handling packages
........
Move package related functions from pmodules to pkgutil.

pmodules.pas => pkgutil.pas:
  * createimportlibfromexports
  * varexport
  * procexport
  * insert_export
  * RewritePPU
........
* adjust indentation
........
Extract the code to export the symbols of a unit to its own function in pkgutil so that less functions need to be exported.

pmodules.pas, proc_package:
  * move code to export the symbols of a unit to new function export_unit
pkgutil.pas:
  + new function export_unit
  - remove exports of procexport, varexport and insert_export
........
Some small fixes for package parsing.

pmodules.pas, proc_package:
  * use orgpattern instead of pattern to build the module name (like is done in uses sections)
  * ignore duplicates when generating exports
  - no need to generate an import library for the package; that is done by the program/library that uses the package
........
+ new unit fpcp of which the class tpcppackage handles the reading and writing of package metadata from/to pcp files (equivalant to tppumodule).
........
+ add unit which contains representation of a PCP file (tpcpfile) like tppufile is for units.
........
Improve export generation.

pkgutil.pas:
  + new function exportprocsym to correctly export a procedure with all its aliases
  + new function exportabstractrecordsymproc to export the members of structured types 
  * insert_export: handle also namespacesym and propertsym (by ignoring them)
  * insert_export: correctly export classes, record and objects
  * insert_export: use new exportprocsym function to export a procsym
  * insert_export: only export public variables of a static symtable


........
+ add entry constants for the name of the package and the package file names, both used by a PCP file
........
* use messages to get rid of most writelns related to package loading
........
Add additional entry types for PCP files

entfile.pas:
  + new entries ibstartrequireds and ibendrequireds to store the list of required packages
  + new entries ibstartcontained and ibendcontained to store the list of contained units
  + new entries ibstartppus and ibendppus to store the list of contained PPU files
........
Generate the PCP file once the package file and the used units were compiled correctly.

pmodules.pas:
  * proc_package: generate the PCP file upon successful compilation
........
Add the possibility to load all packages supplied as parameters.

pkgutil.pas:
  + new function load_packages to load all packages supplied as parameters
pmodules.pas, proc_program:
  * use load_packages to load all packages before any unit is loaded
........
Add code which tries to load a unit from a package first and only then as usual.

fppu.pas, tppumodule:
  + new method loadfrompackage which searches all available packages for the unit and loads it from there if found
  * loadppu: first try to load the unit from a package if any are available
........
Don't link objects files of a unit that is provided by a package.

pmodules.pas, proc_program:
  * if a unit has uf_in_library set we must not include it in the units we link against
........

git-svn-id: trunk@33452 -
This commit is contained in:
svenbarth 2016-04-08 15:40:27 +00:00
parent 0f9e556c80
commit f8e9b33f99
10 changed files with 1300 additions and 302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -174,6 +174,8 @@ compiler/finput.pas svneol=native#text/plain
compiler/fmodule.pas svneol=native#text/plain
compiler/fpccrc.pas svneol=native#text/plain
compiler/fpcdefs.inc svneol=native#text/plain
compiler/fpcp.pas svneol=native#text/pascal
compiler/fpkg.pas svneol=native#text/pascal
compiler/fppu.pas svneol=native#text/plain
compiler/gendef.pas svneol=native#text/plain
compiler/generic/cpuinfo.pas svneol=native#text/plain
@ -524,6 +526,7 @@ compiler/parser.pas svneol=native#text/plain
compiler/pass_1.pas svneol=native#text/plain
compiler/pass_2.pas svneol=native#text/plain
compiler/pbase.pas svneol=native#text/plain
compiler/pcp.pas svneol=native#text/pascal
compiler/pdecl.pas svneol=native#text/plain
compiler/pdecobj.pas svneol=native#text/plain
compiler/pdecsub.pas svneol=native#text/plain
@ -533,6 +536,7 @@ compiler/pexpr.pas svneol=native#text/plain
compiler/pgentype.pas svneol=native#text/pascal
compiler/pgenutil.pas svneol=native#text/pascal
compiler/pinline.pas svneol=native#text/plain
compiler/pkgutil.pas svneol=native#text/pascal
compiler/pmodules.pas svneol=native#text/plain
compiler/powerpc/agppcmpw.pas svneol=native#text/plain
compiler/powerpc/agppcvasm.pas svneol=native#text/plain

6
compiler/entfile.pas
View File

@ -38,6 +38,10 @@ const
subentryid = 2;
{special}
iberror = 0;
ibstartrequireds = 244;
ibendrequireds = 245;
ibstartcontained = 246;
ibendcontained = 247;
ibstartdefs = 248;
ibenddefs = 249;
ibstartsyms = 250;
@ -117,6 +121,8 @@ const
ibmainname = 90;
ibsymtableoptions = 91;
ibrecsymtableoptions = 91;
ibpackagefiles = 92;
ibpackagename = 93;
{ target-specific things }
iblinkotherframeworks = 100;
ibjvmnamespace = 101;

394
compiler/fpcp.pas Normal file
View File

@ -0,0 +1,394 @@
{
Copyright (c) 2013-2016 by Free Pascal development team
This unit implements the loading and searching of package files
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit fpcp;
{$i fpcdefs.inc}
interface
uses
cclasses,
globtype,
pcp,finput,fpkg;
type
tpcppackage=class(tpackage)
private
loaded : boolean;
pcpfile : tpcpfile;
private
function openpcp:boolean;
function search_package(ashortname:boolean):boolean;
function search_package_file:boolean;
procedure setfilename(const fn:string;allowoutput:boolean);
procedure writecontainernames;
procedure writecontainedunits;
procedure readcontainernames;
procedure readcontainedunits;
public
constructor create(const pn:string);
destructor destroy; override;
procedure loadpcp;
procedure savepcp;
procedure initmoduleinfo(module:tmodulebase);
procedure addunit(module:tmodulebase);
end;
implementation
uses
sysutils,
cfileutl,cutils,
systems,globals,version,
verbose,
entfile,fppu;
{ tpcppackage }
function tpcppackage.openpcp: boolean;
var
pcpfiletime : longint;
begin
result:=false;
Message1(package_t_pcp_loading,pcpfilename);
{ Get pcpfile time (also check if the file exists) }
pcpfiletime:=getnamedfiletime(pcpfilename);
if pcpfiletime=-1 then
exit;
{ Open the pcpfile }
Message1(package_u_pcp_name,pcpfilename);
pcpfile:=tpcpfile.create(pcpfilename);
if not pcpfile.openfile then
begin
pcpfile.free;
pcpfile:=nil;
Message(package_u_pcp_file_too_short);
exit;
end;
{ check for a valid PPU file }
if not pcpfile.checkpcpid then
begin
pcpfile.free;
pcpfile:=nil;
Message(package_u_pcp_invalid_header);
exit;
end;
{ check for allowed PCP versions }
if not (pcpfile.getversion=CurrentPCPVersion) then
begin
Message1(package_u_pcp_invalid_version,tostr(pcpfile.getversion));
pcpfile.free;
pcpfile:=nil;
exit;
end;
{ check the target processor }
if tsystemcpu(pcpfile.header.common.cpu)<>target_cpu then
begin
pcpfile.free;
pcpfile:=nil;
Message(package_u_pcp_invalid_processor);
exit;
end;
{ check target }
if tsystem(pcpfile.header.common.target)<>target_info.system then
begin
pcpfile.free;
pcpfile:=nil;
Message(package_u_pcp_invalid_target);
exit;
end;
{$ifdef cpufpemu}
{ check if floating point emulation is on?
fpu emulation isn't unit levelwise because it affects calling convention }
if ((pcpfile.header.common.flags and uf_fpu_emulation)<>0) xor
(cs_fp_emulation in current_settings.moduleswitches) then
begin
pcpfile.free;
pcpfile:=nil;
Message(package_u_pcp_invalid_fpumode);
exit;
end;
{$endif cpufpemu}
{ Load values to be access easier }
//flags:=pcpfile.header.common.flags;
//crc:=pcpfile.header.checksum;
{ Show Debug info }
Message1(package_u_pcp_time,filetimestring(pcpfiletime));
Message1(package_u_pcp_flags,tostr(pcpfile.header.common.flags{flags}));
Message1(package_u_pcp_crc,hexstr(pcpfile.header.checksum,8));
(*Message1(package_u_pcp_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
Message1(package_u_pcp_crc,hexstr(ppufile.header.indirect_checksum,8)+' (indc)');
Comment(V_used,'Number of definitions: '+tostr(ppufile.header.deflistsize));
Comment(V_used,'Number of symbols: '+tostr(ppufile.header.symlistsize));
do_compile:=false;*)
result:=true;
end;
function tpcppackage.search_package(ashortname:boolean):boolean;
var
singlepathstring,
filename : TCmdStr;
function package_exists(const ext:string;var foundfile:TCmdStr):boolean;
begin
if CheckVerbosity(V_Tried) then
Message1(package_t_packagesearch,Singlepathstring+filename+ext);
result:=FindFile(filename+ext,singlepathstring,true,foundfile);
end;
function package_search_path(const s:TCmdStr):boolean;
var
found : boolean;
hs : TCmdStr;
begin
found:=false;
singlepathstring:=FixPath(s,false);
{ Check for package file }
{ TODO }
found:=package_exists({target_info.pkginfoext}'.pcp',hs);
if found then
begin
setfilename(hs,false);
found:=openpcp;
end;
result:=found;
end;
function search_path_list(list:TSearchPathList):boolean;
var
hp : TCmdStrListItem;
found : boolean;
begin
found:=false;
hp:=TCmdStrListItem(list.First);
while assigned(hp) do
begin
found:=package_search_path(hp.Str);
if found then
break;
hp:=TCmdStrListItem(hp.next);
end;
result:=found;
end;
begin
filename:=packagename^;
result:=search_path_list(packagesearchpath);
end;
function tpcppackage.search_package_file: boolean;
var
found : boolean;
begin
found:=false;
if search_package(false) then
found:=true;
if not found and
(length(packagename^)>8) and
search_package(true) then
found:=true;
result:=found;
end;
procedure tpcppackage.setfilename(const fn:string;allowoutput:boolean);
var
p,n : tpathstr;
begin
p:=FixPath(ExtractFilePath(fn),false);
n:=FixFileName(ChangeFileExt(ExtractFileName(fn),''));
{ pcp name }
if allowoutput then
if (OutputUnitDir<>'') then
p:=OutputUnitDir
else
if (OutputExeDir<>'') then
p:=OutputExeDir;
pcpfilename:=p+n+{target_info.pkginfoext}'.pcp';
end;
procedure tpcppackage.writecontainernames;
begin
pcpfile.putstring(pplfilename);
//pcpfile.putstring(ppafilename);
pcpfile.writeentry(ibpackagefiles);
end;
procedure tpcppackage.writecontainedunits;
var
p : pcontainedunit;
i : longint;
begin
pcpfile.putlongint(containedmodules.count);
pcpfile.writeentry(ibstartcontained);
{ for now we write the unit name and the ppu file name }
for i:=0 to containedmodules.count-1 do
begin
p:=pcontainedunit(containedmodules.items[i]);
pcpfile.putstring(p^.module.modulename^);
pcpfile.putstring(p^.ppufile);
end;
pcpfile.writeentry(ibendcontained);
end;
procedure tpcppackage.readcontainernames;
begin
if pcpfile.readentry<>ibpackagefiles then
begin
message(package_f_pcp_read_error);
internalerror(424242);
end;
pplfilename:=pcpfile.getstring;
writeln('PPL filename: ',pplfilename);
end;
procedure tpcppackage.readcontainedunits;
var
cnt,i : longint;
name,path : string;
p : pcontainedunit;
begin
if pcpfile.readentry<>ibstartcontained then
begin
message(package_f_pcp_read_error);
internalerror(424242);
end;
cnt:=pcpfile.getlongint;
if pcpfile.readentry<>ibendcontained then
begin
message(package_f_pcp_read_error);
internalerror(424242);
end;
for i:=0 to cnt-1 do
begin
name:=pcpfile.getstring;
path:=ChangeFileExt(pcpfile.getstring,'.ppl.ppu');
new(p);
p^.module:=nil;
p^.ppufile:=path;
containedmodules.add(name,p);
message1(package_u_contained_unit,name);
end;
end;
constructor tpcppackage.create(const pn: string);
begin
inherited create(pn);
setfilename(pn,true);
end;
destructor tpcppackage.destroy;
begin
pcpfile.free;
inherited destroy;
end;
procedure tpcppackage.loadpcp;
var
newpackagename : string;
begin
if loaded then
exit;
if not search_package_file then
begin
Message1(package_f_cant_find_pcp,realpackagename^);
exit;
end
else
Message1(package_u_pcp_found,realpackagename^);
if not assigned(pcpfile) then
internalerror(2013053101);
if pcpfile.readentry<>ibpackagename then
Message1(package_f_cant_read_pcp,realpackagename^);
newpackagename:=pcpfile.getstring;
if upper(newpackagename)<>packagename^ then
Comment(V_Error,'Package was renamed: '+realpackagename^);
readcontainernames;
//readrequiredpackages
readcontainedunits;
end;
procedure tpcppackage.savepcp;
begin
{ create new ppufile }
pcpfile:=tpcpfile.create(pcpfilename);
if not pcpfile.createfile then
Message2(package_f_cant_create_pcp,realpackagename^,pcpfilename);
pcpfile.putstring(realpackagename^);
pcpfile.writeentry(ibpackagename);
writecontainernames;
//writerequiredpackages;
writecontainedunits;
//writeppus;
{ the last entry ibend is written automatically }
{ flush to be sure }
pcpfile.flush;
{ create and write header }
pcpfile.header.common.size:=pcpfile.size;
pcpfile.header.checksum:=pcpfile.crc;
pcpfile.header.common.compiler:=wordversion;
pcpfile.header.common.cpu:=word(target_cpu);
pcpfile.header.common.target:=word(target_info.system);
//pcpfile.header.flags:=flags;
pcpfile.header.ppulistsize:=containedmodules.count;
pcpfile.header.requiredlistsize:=requiredpackages.count;
pcpfile.writeheader;
{ save crc in current module also }
//crc:=pcpfile.crc;
pcpfile.closefile;
pcpfile.free;
pcpfile:=nil;
end;
procedure tpcppackage.initmoduleinfo(module: tmodulebase);
begin
pplfilename:=extractfilename(module.sharedlibfilename);
end;
procedure tpcppackage.addunit(module: tmodulebase);
var
containedunit : pcontainedunit;
begin
new(containedunit);
containedunit^.module:=module;
containedunit^.ppufile:=extractfilename(module.ppufilename);
containedmodules.add(module.modulename^,containedunit);
end;
end.

131
compiler/fpkg.pas Normal file
View File

@ -0,0 +1,131 @@
{
Copyright (c) 2013-2016 by Free Pascal Development Team
This unit implements basic parts of the package system
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit fpkg;
{$i fpcdefs.inc}
interface
uses
cclasses,
globtype,
finput;
type
tcontainedunit=record
module:tmodulebase;
ppufile:tpathstr;
end;
pcontainedunit=^tcontainedunit;
tpackage=class
public
realpackagename,
packagename : pshortstring;
containedmodules : TFPHashList;
requiredpackages : TFPHashObjectList;
pcpfilename,
ppafilename,
pplfilename : tpathstr;
constructor create(const pn:string);
destructor destroy;override;
end;
tpackageentry=record
package : tpackage;
realpkgname : string;
end;
ppackageentry=^tpackageentry;
procedure addpackage(list:tfphashlist;const pn:string);
implementation
uses
cutils,globals;
procedure addpackage(list: tfphashlist;const pn:string);
var
pkgentry : ppackageentry;
begin
new(pkgentry);
pkgentry^.realpkgname:=pn;
pkgentry^.package:=nil;
list.add(upper(pn),pkgentry);
end;
{ tpackage }
constructor tpackage.create(const pn: string);
begin
realpackagename:=stringdup(pn);
packagename:=stringdup(upper(pn));
containedmodules:=TFPHashList.Create;
requiredpackages:=TFPHashObjectList.Create(false);
end;
destructor tpackage.destroy;
var
p : pcontainedunit;
i : longint;
begin
if assigned(containedmodules) then
for i:=0 to containedmodules.count-1 do
begin
p:=pcontainedunit(containedmodules[i]);
dispose(p);
end;
containedmodules.free;
requiredpackages.free;
inherited destroy;
end;
procedure packageinit;
begin
packagelist:=TFPHashList.Create;
end;
procedure packagedone;
var
i : longint;
pkgentry : ppackageentry;
begin
if assigned(packagelist) then
begin
for i:=0 to packagelist.count-1 do
begin
pkgentry:=ppackageentry(packagelist[i]);
pkgentry^.package.free;
dispose(pkgentry);
end;
end;
packagelist.Free;
packagelist:=nil;
end;
initialization
register_initdone_proc(@packageinit,@packagedone);
end.

93
compiler/fppu.pas
View File

@ -79,6 +79,7 @@ interface
function openppu(ppufiletime:longint):boolean;
function search_unit_files(onlysource:boolean):boolean;
function search_unit(onlysource,shortname:boolean):boolean;
function loadfrompackage:boolean;
procedure load_interface;
procedure load_implementation;
procedure load_usedunits;
@ -121,7 +122,7 @@ uses
aasmbase,ogbase,
parser,
comphook,
entfile;
entfile,fpkg;
var
@ -507,6 +508,86 @@ var
search_unit:=fnd;
end;
function tppumodule.loadfrompackage: boolean;
var
singlepathstring,
filename : TCmdStr;
Function UnitExists(const ext:string;var foundfile:TCmdStr):boolean;
begin
if CheckVerbosity(V_Tried) then
Message1(unit_t_unitsearch,Singlepathstring+filename);
UnitExists:=FindFile(FileName,Singlepathstring,true,foundfile);
end;
Function PPUSearchPath(const s:TCmdStr):boolean;
var
found : boolean;
hs : TCmdStr;
begin
Found:=false;
singlepathstring:=FixPath(s,false);
{ Check for PPU file }
Found:=UnitExists(target_info.unitext,hs);
if Found then
Begin
SetFileName(hs,false);
Found:=openppufile;
End;
PPUSearchPath:=Found;
end;
Function SearchPathList(list:TSearchPathList):boolean;
var
hp : TCmdStrListItem;
found : boolean;
begin
found:=false;
hp:=TCmdStrListItem(list.First);
while assigned(hp) do
begin
found:=PPUSearchPath(hp.Str);
if found then
break;
hp:=TCmdStrListItem(hp.next);
end;
SearchPathList:=found;
end;
var
pkg : ppackageentry;
pkgunit : pcontainedunit;
i,idx : longint;
begin
result:=false;
for i:=0 to packagelist.count-1 do
begin
pkg:=ppackageentry(packagelist[i]);
if not assigned(pkg^.package) then
internalerror(2013053103);
idx:=pkg^.package.containedmodules.FindIndexOf(modulename^);
if idx>=0 then
begin
{ the unit is part of this package }
pkgunit:=pcontainedunit(pkg^.package.containedmodules[idx]);
if not assigned(pkgunit^.module) then
pkgunit^.module:=self;
filename:=pkgunit^.ppufile;
if not SearchPathList(unitsearchpath) then
exit;
{ now load the unit and all used units }
load_interface;
setdefgeneration;
load_usedunits;
Message1(unit_u_finished_loading_unit,modulename^);
result:=true;
break;
end;
end;
end;
{**********************************
PPU Reading/Writing Helpers
@ -1623,6 +1704,16 @@ var
second_time:=false;
set_current_module(self);
{ try to load it as a package unit first }
if (packagelist.count>0) and loadfrompackage then
begin
do_load:=false;
do_reload:=false;
state:=ms_load;
{ add the unit to the used units list of the program }
usedunits.concat(tused_unit.create(self,true,false,nil));
end;
{ A force reload }
if do_reload then
begin

5
compiler/globals.pas
View File

@ -277,6 +277,9 @@ interface
objectsearchpath,
includesearchpath,
frameworksearchpath : TSearchPathList;
packagesearchpath : TSearchPathList;
{ contains tpackageentry entries }
packagelist : TFPHashList;
autoloadunits : string;
{ linking }
@ -1436,6 +1439,7 @@ implementation
frameworksearchpath.Free;
LinkLibraryAliases.Free;
LinkLibraryOrder.Free;
packagesearchpath.Free;
end;
procedure InitGlobals;
@ -1471,6 +1475,7 @@ implementation
includesearchpath:=TSearchPathList.Create;
objectsearchpath:=TSearchPathList.Create;
frameworksearchpath:=TSearchPathList.Create;
packagesearchpath:=TSearchPathList.Create;
{ Def file }
usewindowapi:=false;

29
compiler/options.pas
View File

@ -26,7 +26,7 @@ unit options;
interface
uses
cfileutl,
cfileutl,cclasses,
globtype,globals,verbose,systems,cpuinfo,comprsrc;
Type
@ -48,8 +48,10 @@ Type
ParaUnitPath,
ParaObjectPath,
ParaLibraryPath,
ParaFrameworkPath : TSearchPathList;
ParaFrameworkPath,
parapackagepath : TSearchPathList;
ParaAlignment : TAlignmentInfo;
parapackages : tfphashobjectlist;
paratarget : tsystem;
paratargetasm : tasm;
paratargetdbg : tdbg;
@ -101,6 +103,7 @@ uses
llvminfo,
{$endif llvm}
dirparse,
fpkg,
i_bsd;
const
@ -1547,6 +1550,20 @@ begin
else
ObjectSearchPath.AddPath(More,true);
end;
'P' :
begin
if ispara then
parapackages.add(more,nil)
else
addpackage(packagelist,more);
end;
'p' :
begin
if ispara then
parapackagepath.AddPath(More,false)
else
packagesearchpath.AddPath(More,true);
end;
'r' :
Msgfilename:=More;
'R' :
@ -3123,6 +3140,8 @@ begin
ParaUnitPath:=TSearchPathList.Create;
ParaLibraryPath:=TSearchPathList.Create;
ParaFrameworkPath:=TSearchPathList.Create;
parapackagepath:=TSearchPathList.Create;
parapackages:=TFPHashObjectList.Create;
FillChar(ParaAlignment,sizeof(ParaAlignment),0);
MacVersionSet:=false;
paratarget:=system_none;
@ -3140,6 +3159,8 @@ begin
ParaUnitPath.Free;
ParaLibraryPath.Free;
ParaFrameworkPath.Free;
parapackagepath.Free;
ParaPackages.Free;
end;
@ -3213,6 +3234,7 @@ procedure read_arguments(cmd:TCmdStr);
var
env: ansistring;
i : tfeature;
j : longint;
abi : tabi;
{$if defined(cpucapabilities)}
cpuflag : tcpuflags;
@ -3607,6 +3629,9 @@ begin
IncludeSearchPath.AddList(option.ParaIncludePath,true);
LibrarySearchPath.AddList(option.ParaLibraryPath,true);
FrameworkSearchPath.AddList(option.ParaFrameworkPath,true);
packagesearchpath.addlist(option.parapackagepath,true);
for j:=0 to option.parapackages.count-1 do
addpackage(packagelist,option.parapackages.NameOfIndex(j));
{ add unit environment and exepath to the unit search path }
if inputfilepath<>'' then

188
compiler/pcp.pas Normal file
View File

@ -0,0 +1,188 @@
{
Copyright (c) 2013-2016 by Free Pascal development team
Routines to read/write pcp files
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit pcp;
{$mode objfpc}{$H+}
interface
uses
cstreams,entfile;
const
CurrentPCPVersion=1;
{ unit flags }
//uf_init = $000001; { unit has initialization section }
//uf_finalize = $000002; { unit has finalization section }
pf_big_endian = $000004;
//uf_has_browser = $000010;
//uf_in_library = $000020; { is the file in another file than <ppufile>.* ? }
//uf_smart_linked = $000040; { the ppu can be smartlinked }
//uf_static_linked = $000080; { the ppu can be linked static }
//uf_shared_linked = $000100; { the ppu can be linked shared }
//uf_local_browser = $000200;
//uf_no_link = $000400; { unit has no .o generated, but can still have external linking! }
//uf_has_resourcestrings = $000800; { unit has resource string section }
pf_little_endian = $001000;
type
tpcpheader=record
common : tentryheader;
checksum : cardinal; { checksum for this pcpfile }
requiredlistsize, { number of entries for required packages }
ppulistsize : longint; { number of entries for contained PPUs }
end;
tpcpfile=class(tentryfile)
public
header : tpcpheader;
{ crc for the entire package }
crc : cardinal;
protected
function getheadersize:longint;override;
function getheaderaddr:pentryheader;override;
procedure newheader;override;
function readheader:longint;override;
procedure resetfile;override;
public
procedure writeheader;override;
function checkpcpid:boolean;
end;
implementation
{ tpcpfile }
function tpcpfile.getheadersize: longint;
begin
result:=sizeof(tpcpheader);
end;
function tpcpfile.getheaderaddr: pentryheader;
begin
result:=@header;
end;
procedure tpcpfile.newheader;
var
s : string;
begin
fillchar(header,sizeof(tpcpheader),0);
str(CurrentPCPVersion,s);
while length(s)<3 do
s:='0'+s;
with header.common do
begin
id[1]:='P';
id[2]:='C';
id[3]:='P';
ver[1]:=s[1];
ver[2]:=s[2];
ver[3]:=s[3];
end;
end;
function tpcpfile.readheader: longint;
begin
if fsize<sizeof(tpcpheader) then
exit(0);
result:=f.Read(header,sizeof(tpcpheader));
{ The header is always stored in little endian order }
{ therefore swap if on a big endian machine }
{$IFDEF ENDIAN_BIG}
header.common.compiler := swapendian(header.common.compiler);
header.common.cpu := swapendian(header.common.cpu);
header.common.target := swapendian(header.common.target);
header.common.flags := swapendian(header.common.flags);
header.common.size := swapendian(header.common.size);
header.checksum := swapendian(header.checksum);
header.requiredlistsize:=swapendian(header.requiredlistsize);
header.ppulistsize:=swapendian(header.ppulistsize);
{$ENDIF}
{ the PPU DATA is stored in native order }
if (header.common.flags and pf_big_endian) = pf_big_endian then
Begin
{$IFDEF ENDIAN_LITTLE}
change_endian := TRUE;
{$ELSE}
change_endian := FALSE;
{$ENDIF}
End
else if (header.common.flags and pf_little_endian) = pf_little_endian then
Begin
{$IFDEF ENDIAN_BIG}
change_endian := TRUE;
{$ELSE}
change_endian := FALSE;
{$ENDIF}
End;
end;
procedure tpcpfile.resetfile;
begin
crc:=0;
end;
procedure tpcpfile.writeheader;
var
opos : integer;
begin
{ flush buffer }
writebuf;
{ update size (w/o header!) in the header }
header.common.size:=bufstart-sizeof(tpcpheader);
{ set the endian flag }
{$ifndef FPC_BIG_ENDIAN}
header.common.flags:=header.common.flags or pf_little_endian;
{$else not FPC_BIG_ENDIAN}
header.common.flags:=header.common.flags or pf_big_endian;
{ Now swap the header in the correct endian (always little endian) }
header.common.compiler:=swapendian(header.common.compiler);
header.common.cpu:=swapendian(header.common.cpu);
header.common.target:=swapendian(header.common.target);
header.common.flags:=swapendian(header.common.flags);
header.common.size:=swapendian(header.common.size);
header.checksum:=swapendian(header.checksum);
header.requiredlistsize:=swapendian(header.requiredlistsize);
header.ppulistsize:=swapendian(header.ppulistsize);
{$endif not FPC_BIG_ENDIAN}
{ write header and restore filepos after it }
opos:=f.Position;
f.Position:=0;
f.Write(header,sizeof(tpcpheader));
f.Position:=opos;
end;
function tpcpfile.checkpcpid:boolean;
begin
result:=((Header.common.Id[1]='P') and
(Header.common.Id[2]='C') and
(Header.common.Id[3]='P'));
end;
end.

422
compiler/pkgutil.pas Normal file
View File

@ -0,0 +1,422 @@
{
Copyright (c) 2013-2016 by Free Pascal Development Team
This unit implements basic parts of the package system
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit pkgutil;
{$i fpcdefs.inc}
interface
uses
fmodule;
procedure createimportlibfromexports;
Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
procedure export_unit(u:tmodule);
procedure load_packages;
implementation
uses
sysutils,
globtype,systems,
cutils,cclasses,
globals,verbose,
symtype,symconst,symsym,symdef,symbase,symtable,
ppu,entfile,fpcp,fpkg,
export;
procedure procexport(const s : string);
var
hp : texported_item;
begin
hp:=texported_item.create;
hp.name:=stringdup(s);
hp.options:=hp.options+[eo_name];
exportlib.exportprocedure(hp);
end;
procedure varexport(const s : string);
var
hp : texported_item;
begin
hp:=texported_item.create;
hp.name:=stringdup(s);
hp.options:=hp.options+[eo_name];
exportlib.exportvar(hp);
end;
procedure exportprocsym(sym:tprocsym;symtable:tsymtable);
var
i : longint;
item : TCmdStrListItem;
begin
for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
begin
if not(tprocdef(tprocsym(sym).ProcdefList[i]).proccalloption in [pocall_internproc]) and
((tprocdef(tprocsym(sym).ProcdefList[i]).procoptions*[po_external])=[]) and
((symtable.symtabletype in [globalsymtable,recordsymtable,objectsymtable]) or
((symtable.symtabletype=staticsymtable) and (po_public in tprocdef(tprocsym(sym).ProcdefList[i]).procoptions))
) then
begin
exportallprocdefnames(tprocsym(sym),tprocdef(tprocsym(sym).ProcdefList[i]),[]);
end;
end;
end;
procedure exportabstractrecordsymproc(sym:tobject;arg:pointer);
var
def : tabstractrecorddef;
begin
case tsym(sym).typ of
typesym:
begin
case ttypesym(sym).typedef.typ of
objectdef,
recorddef:
begin
def:=tabstractrecorddef(ttypesym(sym).typedef);
def.symtable.symlist.foreachcall(@exportabstractrecordsymproc,def.symtable);
end;
end;
end;
procsym:
begin
{ don't export methods of interfaces }
if is_interface(tdef(tabstractrecordsymtable(arg).defowner)) then
exit;
exportprocsym(tprocsym(sym),tsymtable(arg));
end;
staticvarsym:
begin
varexport(tsym(sym).mangledname);
end;
end;
end;
procedure insert_export(sym : TObject;arg:pointer);
var
i : longint;
item : TCmdStrListItem;
def : tabstractrecorddef;
hp : texported_item;
publiconly : boolean;
begin
publiconly:=tsymtable(arg).symtabletype=staticsymtable;
case TSym(sym).typ of
{ ignore: }
unitsym,
syssym,
constsym,
namespacesym,
propertysym,
enumsym:
;
typesym:
begin
case ttypesym(sym).typedef.typ of
recorddef,
objectdef:
begin
def:=tabstractrecorddef(ttypesym(sym).typedef);
def.symtable.SymList.ForEachCall(@exportabstractrecordsymproc,def.symtable);
if (def.typ=objectdef) and (oo_has_vmt in tobjectdef(def).objectoptions) then
begin
hp:=texported_item.create;
hp.name:=stringdup(tobjectdef(def).vmt_mangledname);
hp.options:=hp.options+[eo_name];
exportlib.exportvar(hp);
end;
end;
end;
end;
procsym:
begin
exportprocsym(tprocsym(sym),tsymtable(arg));
end;
staticvarsym:
begin
if publiconly and not (vo_is_public in tstaticvarsym(sym).varoptions) then
exit;
varexport(tsym(sym).mangledname);
end;
else
begin
writeln('unknown: ',ord(TSym(sym).typ));
end;
end;
end;
procedure export_unit(u: tmodule);
begin
u.globalsymtable.symlist.ForEachCall(@insert_export,u.globalsymtable);
{ check localsymtable for exports too to get public symbols }
u.localsymtable.symlist.ForEachCall(@insert_export,u.localsymtable);
{ create special exports }
if (u.flags and uf_init)<>0 then
procexport(make_mangledname('INIT$',u.globalsymtable,''));
if (u.flags and uf_finalize)<>0 then
procexport(make_mangledname('FINALIZE$',u.globalsymtable,''));
if (u.flags and uf_threadvars)=uf_threadvars then
varexport(make_mangledname('THREADVARLIST',u.globalsymtable,''));
end;
Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
Var
MakeStatic : Boolean;
Var
buffer : array[0..$1fff] of byte;
inppu,
outppu : tppufile;
b,
untilb : byte;
l,m : longint;
f : file;
ext,
s : string;
ppuversion : dword;
begin
Result:=false;
MakeStatic:=False;
inppu:=tppufile.create(PPUFn);
if not inppu.openfile then
begin
inppu.free;
Comment(V_Error,'Could not open : '+PPUFn);
Exit;
end;
{ Check the ppufile }
if not inppu.CheckPPUId then
begin
inppu.free;
Comment(V_Error,'Not a PPU File : '+PPUFn);
Exit;
end;
ppuversion:=inppu.getversion;
if ppuversion<CurrentPPUVersion then
begin
inppu.free;
Comment(V_Error,'Wrong PPU Version '+tostr(ppuversion)+' in '+PPUFn);
Exit;
end;
{ No .o file generated for this ppu, just skip }
if (inppu.header.common.flags and uf_no_link)<>0 then
begin
inppu.free;
Result:=true;
Exit;
end;
{ Already a lib? }
if (inppu.header.common.flags and uf_in_library)<>0 then
begin
inppu.free;
Comment(V_Error,'PPU is already in a library : '+PPUFn);
Exit;
end;
{ We need a static linked unit }
if (inppu.header.common.flags and uf_static_linked)=0 then
begin
inppu.free;
Comment(V_Error,'PPU is not static linked : '+PPUFn);
Exit;
end;
{ Check if shared is allowed }
if tsystem(inppu.header.common.target) in [system_i386_go32v2] then
begin
Comment(V_Error,'Shared library not supported for ppu target, switching to static library');
MakeStatic:=true;
end;
{ Create the new ppu }
if PPUFn=PPLFn then
outppu:=tppufile.create('ppumove.$$$')
else
outppu:=tppufile.create(PPLFn);
outppu.createfile;
{ Create new header, with the new flags }
outppu.header:=inppu.header;
outppu.header.common.flags:=outppu.header.common.flags or uf_in_library;
if MakeStatic then
outppu.header.common.flags:=outppu.header.common.flags or uf_static_linked
else
outppu.header.common.flags:=outppu.header.common.flags or uf_shared_linked;
{ read until the object files are found }
untilb:=iblinkunitofiles;
repeat
b:=inppu.readentry;
if b in [ibendinterface,ibend] then
begin
inppu.free;
outppu.free;
Comment(V_Error,'No files to be linked found : '+PPUFn);
Exit;
end;
if b<>untilb then
begin
repeat
inppu.getdatabuf(buffer,sizeof(buffer),l);
outppu.putdata(buffer,l);
until l<sizeof(buffer);
outppu.writeentry(b);
end;
until (b=untilb);
{ we have now reached the section for the files which need to be added,
now add them to the list }
case b of
iblinkunitofiles :
begin
{ add all o files, and save the entry when not creating a static
library to keep staticlinking possible }
while not inppu.endofentry do
begin
s:=inppu.getstring;
m:=inppu.getlongint;
if not MakeStatic then
begin
outppu.putstring(s);
outppu.putlongint(m);
end;
current_module.linkotherofiles.add(s,link_always);;
end;
if not MakeStatic then
outppu.writeentry(b);
end;
{ iblinkunitstaticlibs :
begin
AddToLinkFiles(ExtractLib(inppu.getstring));
if not inppu.endofentry then
begin
repeat
inppu.getdatabuf(buffer^,bufsize,l);
outppu.putdata(buffer^,l);
until l<bufsize;
outppu.writeentry(b);
end;
end; }
end;
{ just add a new entry with the new lib }
if MakeStatic then
begin
outppu.putstring('imp'+current_module.realmodulename^);
outppu.putlongint(link_static);
outppu.writeentry(iblinkunitstaticlibs)
end
else
begin
outppu.putstring('imp'+current_module.realmodulename^);
outppu.putlongint(link_shared);
outppu.writeentry(iblinkunitsharedlibs);
end;
{ read all entries until the end and write them also to the new ppu }
repeat
b:=inppu.readentry;
{ don't write ibend, that's written automatically }
if b<>ibend then
begin
if b=iblinkothersharedlibs then
begin
while not inppu.endofentry do
begin
s:=inppu.getstring;
m:=inppu.getlongint;
outppu.putstring(s);
outppu.putlongint(m);
{ strip lib prefix }
if copy(s,1,3)='lib' then
delete(s,1,3);
ext:=ExtractFileExt(s);
if ext<>'' then
delete(s,length(s)-length(ext)+1,length(ext));
current_module.linkOtherSharedLibs.add(s,link_always);
end;
end
else
repeat
inppu.getdatabuf(buffer,sizeof(buffer),l);
outppu.putdata(buffer,l);
until l<sizeof(buffer);
outppu.writeentry(b);
end;
until b=ibend;
{ write the last stuff and close }
outppu.flush;
outppu.writeheader;
outppu.free;
inppu.free;
{ rename }
if PPUFn=PPLFn then
begin
{$push}{$I-}
assign(f,PPUFn);
erase(f);
assign(f,'ppumove.$$$');
rename(f,PPUFn);
{$pop}
if ioresult<>0 then;
end;
Result:=True;
end;
procedure load_packages;
var
i : longint;
pcp: tpcppackage;
entry : ppackageentry;
begin
if not (tf_supports_packages in target_info.flags) then
exit;
for i:=0 to packagelist.count-1 do
begin
entry:=ppackageentry(packagelist[i]);
if assigned(entry^.package) then
internalerror(2013053104);
Comment(V_Info,'Loading package: '+entry^.realpkgname);
pcp:=tpcppackage.create(entry^.realpkgname);
pcp.loadpcp;
entry^.package:=pcp;
end;
end;
procedure createimportlibfromexports;
var
hp : texported_item;
begin
hp:=texported_item(current_module._exports.first);
while assigned(hp) do
begin
current_module.AddExternalImport(current_module.realmodulename^,hp.name^,hp.name^,hp.index,hp.is_var,false);
hp:=texported_item(hp.next);
end;
end;
end.

330
compiler/pmodules.pas
View File

@ -41,10 +41,11 @@ implementation
aasmtai,aasmdata,aasmcpu,aasmbase,
cgbase,cgobj,ngenutil,
nbas,nutils,ncgutil,
link,assemble,import,export,gendef,entfile,ppu,comprsrc,dbgbase,
link,assemble,import,export,gendef,entfile,ppu,comprsrc,dbgbase,fpcp,
cresstr,procinfo,
pexports,
objcgutl,
pkgutil,
wpobase,
scanner,pbase,pexpr,psystem,psub,pdecsub,ncgvmt,ncgrtti,
cpuinfo;
@ -1370,292 +1371,11 @@ type
end;
procedure procexport(const s : string);
var
hp : texported_item;
begin
hp:=texported_item.create;
hp.name:=stringdup(s);
include(hp.options,eo_name);
exportlib.exportprocedure(hp);
end;
procedure varexport(const s : string);
var
hp : texported_item;
begin
hp:=texported_item.create;
hp.name:=stringdup(s);
include(hp.options,eo_name);
exportlib.exportvar(hp);
end;
procedure insert_export(sym : TObject;arg:pointer);
var
i : longint;
item : TCmdStrListItem;
begin
case TSym(sym).typ of
{ ignore: }
unitsym,
syssym,
constsym,
enumsym,
typesym:
;
procsym:
begin
for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
begin
if not(tprocdef(tprocsym(sym).ProcdefList[i]).proccalloption in [pocall_internproc]) and
((tprocdef(tprocsym(sym).ProcdefList[i]).procoptions*[po_external])=[]) and
((tsymtable(arg).symtabletype=globalsymtable) or
((tsymtable(arg).symtabletype=staticsymtable) and (po_public in tprocdef(tprocsym(sym).ProcdefList[i]).procoptions))
) then
begin
procexport(tprocdef(tprocsym(sym).ProcdefList[i]).mangledname);
{ walk through all aliases }
item:=TCmdStrListItem(tprocdef(tprocsym(sym).ProcdefList[i]).aliasnames.first);
while assigned(item) do
begin
{ avoid duplicate entries, sometimes aliasnames contains the mangledname }
if item.str<>tprocdef(tprocsym(sym).ProcdefList[i]).mangledname then
procexport(item.str);
item:=TCmdStrListItem(item.next);
end;
end;
end;
end;
staticvarsym:
begin
varexport(tsym(sym).mangledname);
end;
else
begin
writeln('unknown: ',ord(TSym(sym).typ));
end;
end;
end;
Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
Var
MakeStatic : Boolean;
Var
buffer : array[0..$1fff] of byte;
inppu,
outppu : tppufile;
b,
untilb : byte;
l,m : longint;
f : file;
ext,
s : string;
ppuversion : dword;
begin
Result:=false;
MakeStatic:=False;
inppu:=tppufile.create(PPUFn);
if not inppu.openfile then
begin
inppu.free;
Comment(V_Error,'Could not open : '+PPUFn);
Exit;
end;
{ Check the ppufile }
if not inppu.CheckPPUId then
begin
inppu.free;
Comment(V_Error,'Not a PPU File : '+PPUFn);
Exit;
end;
ppuversion:=inppu.getversion;
if ppuversion<CurrentPPUVersion then
begin
inppu.free;
Comment(V_Error,'Wrong PPU Version '+tostr(ppuversion)+' in '+PPUFn);
Exit;
end;
{ No .o file generated for this ppu, just skip }
if (inppu.header.common.flags and uf_no_link)<>0 then
begin
inppu.free;
Result:=true;
Exit;
end;
{ Already a lib? }
if (inppu.header.common.flags and uf_in_library)<>0 then
begin
inppu.free;
Comment(V_Error,'PPU is already in a library : '+PPUFn);
Exit;
end;
{ We need a static linked unit }
if (inppu.header.common.flags and uf_static_linked)=0 then
begin
inppu.free;
Comment(V_Error,'PPU is not static linked : '+PPUFn);
Exit;
end;
{ Check if shared is allowed }
if tsystem(inppu.header.common.target) in [system_i386_go32v2] then
begin
Comment(V_Error,'Shared library not supported for ppu target, switching to static library');
MakeStatic:=true;
end;
{ Create the new ppu }
if PPUFn=PPLFn then
outppu:=tppufile.create('ppumove.$$$')
else
outppu:=tppufile.create(PPLFn);
outppu.createfile;
{ Create new header, with the new flags }
outppu.header:=inppu.header;
outppu.header.common.flags:=outppu.header.common.flags or uf_in_library;
if MakeStatic then
outppu.header.common.flags:=outppu.header.common.flags or uf_static_linked
else
outppu.header.common.flags:=outppu.header.common.flags or uf_shared_linked;
{ read until the object files are found }
untilb:=iblinkunitofiles;
repeat
b:=inppu.readentry;
if b in [ibendinterface,ibend] then
begin
inppu.free;
outppu.free;
Comment(V_Error,'No files to be linked found : '+PPUFn);
Exit;
end;
if b<>untilb then
begin
repeat
inppu.getdatabuf(buffer,sizeof(buffer),l);
outppu.putdata(buffer,l);
until l<sizeof(buffer);
outppu.writeentry(b);
end;
until (b=untilb);
{ we have now reached the section for the files which need to be added,
now add them to the list }
case b of
iblinkunitofiles :
begin
{ add all o files, and save the entry when not creating a static
library to keep staticlinking possible }
while not inppu.endofentry do
begin
s:=inppu.getstring;
m:=inppu.getlongint;
if not MakeStatic then
begin
outppu.putstring(s);
outppu.putlongint(m);
end;
current_module.linkotherofiles.add(s,link_always);;
end;
if not MakeStatic then
outppu.writeentry(b);
end;
{ iblinkunitstaticlibs :
begin
AddToLinkFiles(ExtractLib(inppu.getstring));
if not inppu.endofentry then
begin
repeat
inppu.getdatabuf(buffer^,bufsize,l);
outppu.putdata(buffer^,l);
until l<bufsize;
outppu.writeentry(b);
end;
end; }
end;
{ just add a new entry with the new lib }
if MakeStatic then
begin
outppu.putstring('imp'+current_module.realmodulename^);
outppu.putlongint(link_static);
outppu.writeentry(iblinkunitstaticlibs)
end
else
begin
outppu.putstring('imp'+current_module.realmodulename^);
outppu.putlongint(link_shared);
outppu.writeentry(iblinkunitsharedlibs);
end;
{ read all entries until the end and write them also to the new ppu }
repeat
b:=inppu.readentry;
{ don't write ibend, that's written automatically }
if b<>ibend then
begin
if b=iblinkothersharedlibs then
begin
while not inppu.endofentry do
begin
s:=inppu.getstring;
m:=inppu.getlongint;
outppu.putstring(s);
outppu.putlongint(m);
{ strip lib prefix }
if copy(s,1,3)='lib' then
delete(s,1,3);
ext:=ExtractFileExt(s);
if ext<>'' then
delete(s,length(s)-length(ext)+1,length(ext));
current_module.linkOtherSharedLibs.add(s,link_always);
end;
end
else
repeat
inppu.getdatabuf(buffer,sizeof(buffer),l);
outppu.putdata(buffer,l);
until l<sizeof(buffer);
outppu.writeentry(b);
end;
until b=ibend;
{ write the last stuff and close }
outppu.flush;
outppu.writeheader;
outppu.free;
inppu.free;
{ rename }
if PPUFn=PPLFn then
begin
{$push}{$I-}
assign(f,PPUFn);
erase(f);
assign(f,'ppumove.$$$');
rename(f,PPUFn);
{$pop}
if ioresult<>0 then;
end;
Result:=True;
end;
procedure createimportlibfromexports;
var
hp : texported_item;
begin
hp:=texported_item(current_module._exports.first);
while assigned(hp) do
begin
current_module.AddExternalImport(current_module.realmodulename^,hp.name^,hp.name^,hp.index,hp.is_var,false);
hp:=texported_item(hp.next);
end;
end;
procedure proc_package;
var
main_file : tinputfile;
hp,hp2 : tmodule;
pkg : tpcppackage;
{finalize_procinfo,
init_procinfo,
main_procinfo : tcgprocinfo;}
@ -1753,7 +1473,7 @@ type
begin
if token=_ID then
begin
module_name:=pattern;
module_name:=orgpattern;
consume(_ID);
while token=_POINT do
begin
@ -1847,21 +1567,13 @@ type
loaded_units.remove(hp2);
end;
exportlib.ignoreduplicates:=true;
{ force exports }
uu:=tused_unit(usedunits.first);
while assigned(uu) do
begin
uu.u.globalsymtable.symlist.ForEachCall(@insert_export,uu.u.globalsymtable);
{ check localsymtable for exports too to get public symbols }
uu.u.localsymtable.symlist.ForEachCall(@insert_export,uu.u.localsymtable);
{ create special exports }
if (uu.u.flags and uf_init)<>0 then
procexport(make_mangledname('INIT$',uu.u.globalsymtable,''));
if (uu.u.flags and uf_finalize)<>0 then
procexport(make_mangledname('FINALIZE$',uu.u.globalsymtable,''));
if (uu.u.flags and uf_threadvars)=uf_threadvars then
varexport(make_mangledname('THREADVARLIST',uu.u.globalsymtable,''));
export_unit(uu.u);
uu:=tused_unit(uu.next);
end;
@ -1879,9 +1591,7 @@ type
exportlib.generatelib;
{ write all our exports to the import library,
needs to be done after exportlib.generatelib; }
createimportlibfromexports;
exportlib.ignoreduplicates:=false;
{ generate imports }
if current_module.ImportLibraryList.Count>0 then
@ -1915,6 +1625,18 @@ type
if (not current_module.is_unit) then
begin
{ add all contained units to the package }
{ TODO : handle implicitly imported units }
pkg:=tpcppackage.create(module_name);
uu:=tused_unit(current_module.used_units.first);
while assigned(uu) do
begin
pkg.addunit(uu.u);
uu:=tused_unit(uu.next);
end;
pkg.initmoduleinfo(current_module);
{ finally rewrite all units included into the package }
uu:=tused_unit(usedunits.first);
while assigned(uu) do
@ -1931,6 +1653,10 @@ type
{ write .def file }
if (cs_link_deffile in current_settings.globalswitches) then
deffile.writefile;
{ generate the pcp file }
pkg.savepcp;
{ insert all .o files from all loaded units and
unload the units, we don't need them anymore.
Keep the current_module because that is still needed }
@ -1957,6 +1683,8 @@ type
Message1(unit_f_errors_in_unit,tostr(Errorcount));
status.skip_error:=true;
end;
pkg.free;
end;
end;
@ -2111,6 +1839,10 @@ type
setupglobalswitches;
end;
{ load all packages, so we know whether a unit is contained inside a
package or not }
load_packages;
{ global switches are read, so further changes aren't allowed }
current_module.in_global:=false;
@ -2439,7 +2171,7 @@ type
hp:=tmodule(loaded_units.first);
while assigned(hp) do
begin
if (hp<>sysinitmod) then
if (hp<>sysinitmod) and (hp.flags and uf_in_library=0) then
linker.AddModuleFiles(hp);
hp2:=tmodule(hp.next);
if (hp<>current_module) and