浏览代码

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

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 -
svenbarth 9 年之前
父节点
当前提交
f8e9b33f99
共有 10 个文件被更改,包括 1300 次插入302 次删除
  1. 4 0
      .gitattributes
  2. 6 0
      compiler/entfile.pas
  3. 394 0
      compiler/fpcp.pas
  4. 131 0
      compiler/fpkg.pas
  5. 92 1
      compiler/fppu.pas
  6. 5 0
      compiler/globals.pas
  7. 27 2
      compiler/options.pas
  8. 188 0
      compiler/pcp.pas
  9. 422 0
      compiler/pkgutil.pas
  10. 31 299
      compiler/pmodules.pas

+ 4 - 0
.gitattributes

@@ -174,6 +174,8 @@ compiler/finput.pas svneol=native#text/plain
 compiler/fmodule.pas svneol=native#text/plain
 compiler/fmodule.pas svneol=native#text/plain
 compiler/fpccrc.pas svneol=native#text/plain
 compiler/fpccrc.pas svneol=native#text/plain
 compiler/fpcdefs.inc 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/fppu.pas svneol=native#text/plain
 compiler/gendef.pas svneol=native#text/plain
 compiler/gendef.pas svneol=native#text/plain
 compiler/generic/cpuinfo.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_1.pas svneol=native#text/plain
 compiler/pass_2.pas svneol=native#text/plain
 compiler/pass_2.pas svneol=native#text/plain
 compiler/pbase.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/pdecl.pas svneol=native#text/plain
 compiler/pdecobj.pas svneol=native#text/plain
 compiler/pdecobj.pas svneol=native#text/plain
 compiler/pdecsub.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/pgentype.pas svneol=native#text/pascal
 compiler/pgenutil.pas svneol=native#text/pascal
 compiler/pgenutil.pas svneol=native#text/pascal
 compiler/pinline.pas svneol=native#text/plain
 compiler/pinline.pas svneol=native#text/plain
+compiler/pkgutil.pas svneol=native#text/pascal
 compiler/pmodules.pas svneol=native#text/plain
 compiler/pmodules.pas svneol=native#text/plain
 compiler/powerpc/agppcmpw.pas svneol=native#text/plain
 compiler/powerpc/agppcmpw.pas svneol=native#text/plain
 compiler/powerpc/agppcvasm.pas svneol=native#text/plain
 compiler/powerpc/agppcvasm.pas svneol=native#text/plain

+ 6 - 0
compiler/entfile.pas

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

+ 394 - 0
compiler/fpcp.pas

@@ -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 - 0
compiler/fpkg.pas

@@ -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.
+

+ 92 - 1
compiler/fppu.pas

@@ -79,6 +79,7 @@ interface
           function  openppu(ppufiletime:longint):boolean;
           function  openppu(ppufiletime:longint):boolean;
           function  search_unit_files(onlysource:boolean):boolean;
           function  search_unit_files(onlysource:boolean):boolean;
           function  search_unit(onlysource,shortname:boolean):boolean;
           function  search_unit(onlysource,shortname:boolean):boolean;
+          function  loadfrompackage:boolean;
           procedure load_interface;
           procedure load_interface;
           procedure load_implementation;
           procedure load_implementation;
           procedure load_usedunits;
           procedure load_usedunits;
@@ -121,7 +122,7 @@ uses
   aasmbase,ogbase,
   aasmbase,ogbase,
   parser,
   parser,
   comphook,
   comphook,
-  entfile;
+  entfile,fpkg;
 
 
 
 
 var
 var
@@ -507,6 +508,86 @@ var
          search_unit:=fnd;
          search_unit:=fnd;
       end;
       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
     PPU Reading/Writing Helpers
@@ -1623,6 +1704,16 @@ var
         second_time:=false;
         second_time:=false;
         set_current_module(self);
         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 }
         { A force reload }
         if do_reload then
         if do_reload then
          begin
          begin

+ 5 - 0
compiler/globals.pas

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

+ 27 - 2
compiler/options.pas

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

+ 188 - 0
compiler/pcp.pas

@@ -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 - 0
compiler/pkgutil.pas

@@ -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.
+

+ 31 - 299
compiler/pmodules.pas

@@ -41,10 +41,11 @@ implementation
        aasmtai,aasmdata,aasmcpu,aasmbase,
        aasmtai,aasmdata,aasmcpu,aasmbase,
        cgbase,cgobj,ngenutil,
        cgbase,cgobj,ngenutil,
        nbas,nutils,ncgutil,
        nbas,nutils,ncgutil,
-       link,assemble,import,export,gendef,entfile,ppu,comprsrc,dbgbase,
+       link,assemble,import,export,gendef,entfile,ppu,comprsrc,dbgbase,fpcp,
        cresstr,procinfo,
        cresstr,procinfo,
        pexports,
        pexports,
        objcgutl,
        objcgutl,
+       pkgutil,
        wpobase,
        wpobase,
        scanner,pbase,pexpr,psystem,psub,pdecsub,ncgvmt,ncgrtti,
        scanner,pbase,pexpr,psystem,psub,pdecsub,ncgvmt,ncgrtti,
        cpuinfo;
        cpuinfo;
@@ -1370,292 +1371,11 @@ type
       end;
       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;
     procedure proc_package;
       var
       var
         main_file : tinputfile;
         main_file : tinputfile;
         hp,hp2    : tmodule;
         hp,hp2    : tmodule;
+        pkg : tpcppackage;
         {finalize_procinfo,
         {finalize_procinfo,
         init_procinfo,
         init_procinfo,
         main_procinfo : tcgprocinfo;}
         main_procinfo : tcgprocinfo;}
@@ -1753,7 +1473,7 @@ type
                begin
                begin
                  if token=_ID then
                  if token=_ID then
                    begin
                    begin
-                     module_name:=pattern;
+                     module_name:=orgpattern;
                      consume(_ID);
                      consume(_ID);
                      while token=_POINT do
                      while token=_POINT do
                        begin
                        begin
@@ -1847,21 +1567,13 @@ type
               loaded_units.remove(hp2);
               loaded_units.remove(hp2);
           end;
           end;
 
 
+         exportlib.ignoreduplicates:=true;
+
          { force exports }
          { force exports }
          uu:=tused_unit(usedunits.first);
          uu:=tused_unit(usedunits.first);
          while assigned(uu) do
          while assigned(uu) do
            begin
            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);
              uu:=tused_unit(uu.next);
            end;
            end;
@@ -1879,9 +1591,7 @@ type
 
 
          exportlib.generatelib;
          exportlib.generatelib;
 
 
-         { write all our exports to the import library,
-           needs to be done after exportlib.generatelib; }
-         createimportlibfromexports;
+         exportlib.ignoreduplicates:=false;
 
 
          { generate imports }
          { generate imports }
          if current_module.ImportLibraryList.Count>0 then
          if current_module.ImportLibraryList.Count>0 then
@@ -1915,6 +1625,18 @@ type
 
 
          if (not current_module.is_unit) then
          if (not current_module.is_unit) then
            begin
            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 }
              { finally rewrite all units included into the package }
              uu:=tused_unit(usedunits.first);
              uu:=tused_unit(usedunits.first);
              while assigned(uu) do
              while assigned(uu) do
@@ -1931,6 +1653,10 @@ type
                  { write .def file }
                  { write .def file }
                  if (cs_link_deffile in current_settings.globalswitches) then
                  if (cs_link_deffile in current_settings.globalswitches) then
                    deffile.writefile;
                    deffile.writefile;
+
+                 { generate the pcp file }
+                 pkg.savepcp;
+
                  { insert all .o files from all loaded units and
                  { insert all .o files from all loaded units and
                    unload the units, we don't need them anymore.
                    unload the units, we don't need them anymore.
                    Keep the current_module because that is still needed }
                    Keep the current_module because that is still needed }
@@ -1957,6 +1683,8 @@ type
                 Message1(unit_f_errors_in_unit,tostr(Errorcount));
                 Message1(unit_f_errors_in_unit,tostr(Errorcount));
                 status.skip_error:=true;
                 status.skip_error:=true;
               end;
               end;
+
+             pkg.free;
           end;
           end;
       end;
       end;
 
 
@@ -2111,6 +1839,10 @@ type
              setupglobalswitches;
              setupglobalswitches;
            end;
            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 }
          { global switches are read, so further changes aren't allowed }
          current_module.in_global:=false;
          current_module.in_global:=false;
 
 
@@ -2439,7 +2171,7 @@ type
                  hp:=tmodule(loaded_units.first);
                  hp:=tmodule(loaded_units.first);
                  while assigned(hp) do
                  while assigned(hp) do
                   begin
                   begin
-                    if (hp<>sysinitmod) then
+                    if (hp<>sysinitmod) and (hp.flags and uf_in_library=0) then
                       linker.AddModuleFiles(hp);
                       linker.AddModuleFiles(hp);
                     hp2:=tmodule(hp.next);
                     hp2:=tmodule(hp.next);
                     if (hp<>current_module) and
                     if (hp<>current_module) and