From f8e9b33f99f7ae3982ca17bf0cc56d236dd42b41 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Fri, 8 Apr 2016 15:40:27 +0000 Subject: [PATCH] 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 - --- .gitattributes | 4 + compiler/entfile.pas | 6 + compiler/fpcp.pas | 394 +++++++++++++++++++++++++++++++++++++++ compiler/fpkg.pas | 131 +++++++++++++ compiler/fppu.pas | 93 +++++++++- compiler/globals.pas | 5 + compiler/options.pas | 29 ++- compiler/pcp.pas | 188 +++++++++++++++++++ compiler/pkgutil.pas | 422 ++++++++++++++++++++++++++++++++++++++++++ compiler/pmodules.pas | 330 ++++----------------------------- 10 files changed, 1300 insertions(+), 302 deletions(-) create mode 100644 compiler/fpcp.pas create mode 100644 compiler/fpkg.pas create mode 100644 compiler/pcp.pas create mode 100644 compiler/pkgutil.pas diff --git a/.gitattributes b/.gitattributes index c013f32b81..0cef9a3d8b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/compiler/entfile.pas b/compiler/entfile.pas index 3b9f5c0f3e..7ae9cabd3f 100644 --- a/compiler/entfile.pas +++ b/compiler/entfile.pas @@ -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; diff --git a/compiler/fpcp.pas b/compiler/fpcp.pas new file mode 100644 index 0000000000..092d199abe --- /dev/null +++ b/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. + diff --git a/compiler/fpkg.pas b/compiler/fpkg.pas new file mode 100644 index 0000000000..c4377820bb --- /dev/null +++ b/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. + diff --git a/compiler/fppu.pas b/compiler/fppu.pas index 3dc18ccb7f..2ad86fc2bd 100644 --- a/compiler/fppu.pas +++ b/compiler/fppu.pas @@ -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 diff --git a/compiler/globals.pas b/compiler/globals.pas index 62b5933ab1..224a66b082 100644 --- a/compiler/globals.pas +++ b/compiler/globals.pas @@ -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; diff --git a/compiler/options.pas b/compiler/options.pas index c37887e5b0..3ed985bd3e 100644 --- a/compiler/options.pas +++ b/compiler/options.pas @@ -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 diff --git a/compiler/pcp.pas b/compiler/pcp.pas new file mode 100644 index 0000000000..801070ede6 --- /dev/null +++ b/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 .* ? } + //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 fsize0 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 ppuversion0 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 libend 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 l0 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. + diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index 510d1b912c..715d250939 100644 --- a/compiler/pmodules.pas +++ b/compiler/pmodules.pas @@ -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 ppuversion0 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 libend 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 l0 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