+ basic parsing of package files

+ basic implementation of creation of packages

git-svn-id: trunk@9054 -

compiler/comphook.pas

@@ -87,6 +87,7 @@ type
     datasize      : aint;
   { program info }
     isexe,
+    ispackage,
     islibrary     : boolean;
   { Settings for the output }
     verbosity     : longint;

compiler/fmodule.pas

@@ -115,6 +115,7 @@ interface
         interface_crc : cardinal;
         flags         : cardinal;  { the PPU flags }
         islibrary     : boolean;  { if it is a library (win32 dll) }
+        IsPackage     : boolean;
         moduleid      : longint;
         unitmap       : punitmap; { mapping of all used units }
         unitmapsize   : longint;  { number of units in the map }
@@ -498,6 +499,7 @@ implementation
         in_global:=true;
         is_unit:=_is_unit;
         islibrary:=false;
+        ispackage:=false;
         is_dbginfo_written:=false;
         is_reset:=false;
         mode_switch_allowed:= true;

compiler/parser.pas

@@ -378,6 +378,11 @@ implementation
                  current_module.is_unit:=true;
                  proc_unit;
                end
+             else if (token=_ID) and (idtoken=_PACKAGE) then
+               begin
+                 current_module.IsPackage:=true;
+                 proc_package;
+               end
              else
                proc_program(token=_LIBRARY);
            except

compiler/pmodules.pas

@@ -26,6 +26,7 @@ unit pmodules;
 interface
 
     procedure proc_unit;
+    procedure proc_package;
     procedure proc_program(islibrary : boolean);
 
 
@@ -1187,6 +1188,306 @@ implementation
       end;
 
 
+    procedure insert_export(sym : TObject;arg:pointer);
+      var
+        hp : texported_item;
+        i : longint;
+      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]) then
+                    begin
+                      hp:=texported_item.create;
+                      // hp.sym:=tsym(sym);
+                      hp.name:=stringdup(tprocdef(tprocsym(sym).ProcdefList[i]).mangledname);
+                      hp.options:=hp.options or eo_name;
+                      exportlib.exportprocedure(hp)
+                    end;
+                end;
+            end;
+          staticvarsym:
+            begin
+              hp:=texported_item.create;
+              // hp.sym:=tsym(sym);
+              hp.name:=stringdup(tsym(sym).mangledname);
+              hp.options:=hp.options or eo_name;
+              exportlib.exportvar(hp);
+            end;
+          else
+            begin
+              writeln('unknown: ',ord(TSym(sym).typ));
+            end;
+        end;
+      end;
+
+
+    procedure proc_package;
+      var
+        main_file : tinputfile;
+        hp,hp2    : tmodule;
+        finalize_procinfo,
+        init_procinfo,
+        main_procinfo : tcgprocinfo;
+        force_init_final : boolean;
+        uu : tused_unit;
+      begin
+         Status.IsPackage:=true;
+         Status.IsExe:=true;
+         parse_only:=false;
+         main_procinfo:=nil;
+         init_procinfo:=nil;
+         finalize_procinfo:=nil;
+
+         if not RelocSectionSetExplicitly then
+           RelocSection:=true;
+
+         { Relocation works only without stabs under Windows when }
+         { external linker (LD) is used.  LD generates relocs for }
+         { stab sections which is not loaded in memory. It causes }
+         { AV error when DLL is loaded and relocation is needed.  }
+         { Internal linker does not have this problem.            }
+         if RelocSection and
+            (target_info.system in system_all_windows+[system_i386_wdosx]) and
+            (cs_link_extern in current_settings.globalswitches) then
+           begin
+              include(current_settings.globalswitches,cs_link_strip);
+              { Warning stabs info does not work with reloc section !! }
+              if cs_debuginfo in current_settings.moduleswitches then
+                begin
+                  Message1(parser_w_parser_reloc_no_debug,current_module.mainsource^);
+                  Message(parser_w_parser_win32_debug_needs_WN);
+                  exclude(current_settings.moduleswitches,cs_debuginfo);
+                end;
+           end;
+         { get correct output names }
+         main_file := current_scanner.inputfile;
+         while assigned(main_file.next) do
+           main_file := main_file.next;
+
+         current_module.SetFileName(main_file.path^+main_file.name^,true);
+
+         consume(_ID);
+         current_module.setmodulename(orgpattern);
+         current_module.ispackage:=true;
+         exportlib.preparelib(orgpattern);
+
+         if tf_library_needs_pic in target_info.flags then
+           include(current_settings.moduleswitches,cs_create_pic);
+
+         consume(_ID);
+         consume(_SEMICOLON);
+
+         { global switches are read, so further changes aren't allowed }
+         current_module.in_global:=false;
+
+         { setup things using the switches }
+         setupglobalswitches;
+
+         { set implementation flag }
+         current_module.in_interface:=false;
+         current_module.interface_compiled:=true;
+
+         { insert after the unit symbol tables the static symbol table }
+         { of the program                                             }
+         current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
+
+         {Load the units used by the program we compile.}
+         if token=_REQUIRES then
+           begin
+           end;
+
+         {Load the units used by the program we compile.}
+         if (token=_ID) and (idtoken=_CONTAINS) then
+           begin
+             consume(_ID);
+             while true do
+               begin
+                 if token=_ID then
+                   AddUnit(pattern);
+                 consume(_ID);
+                 if token=_COMMA then
+                   consume(_COMMA)
+                 else break;
+               end;
+             consume(_SEMICOLON);
+           end;
+
+         { reset ranges/stabs in exported definitions }
+         reset_all_defs;
+
+         { All units are read, now give them a number }
+         current_module.updatemaps;
+
+         {Insert the name of the main program into the symbol table.}
+         if current_module.realmodulename^<>'' then
+           current_module.localsymtable.insert(tunitsym.create(current_module.realmodulename^,current_module));
+
+         Message1(parser_u_parsing_implementation,current_module.mainsource^);
+
+         symtablestack.push(current_module.localsymtable);
+
+         { should we force unit initialization? }
+         force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
+         if force_init_final then
+           init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable);
+
+         { Add symbol to the exports section for win32 so smartlinking a
+           DLL will include the edata section }
+         if assigned(exportlib) and
+            (target_info.system in [system_i386_win32,system_i386_wdosx]) and
+            ((current_module.flags and uf_has_exports)<>0) then
+           current_asmdata.asmlists[al_procedures].concat(tai_const.createname(make_mangledname('EDATA',current_module.localsymtable,''),0));
+
+         { all labels must be defined before generating code }
+         if Errorcount=0 then
+           tstoredsymtable(current_module.localsymtable).checklabels;
+
+         symtablestack.pop(current_module.localsymtable);
+
+         { consume the last point }
+         consume(_END);
+         consume(_POINT);
+
+         if (Errorcount=0) then
+           begin
+             { test static symtable }
+             tstoredsymtable(current_module.localsymtable).allsymbolsused;
+             tstoredsymtable(current_module.localsymtable).allprivatesused;
+             tstoredsymtable(current_module.localsymtable).check_forwards;
+             tstoredsymtable(current_module.localsymtable).unchain_overloaded;
+
+             current_module.allunitsused;
+           end;
+
+         new_section(current_asmdata.asmlists[al_globals],sec_data,'_FPCDummy',4);
+         current_asmdata.asmlists[al_globals].concat(tai_symbol.createname_global('_FPCDummy',AT_DATA,0));
+         current_asmdata.asmlists[al_globals].concat(tai_const.create_32bit(0));
+
+         new_section(current_asmdata.asmlists[al_procedures],sec_code,'',0);
+         current_asmdata.asmlists[al_procedures].concat(tai_symbol.createname_global('_DLLMainCRTStartup',AT_FUNCTION,0));
+         current_asmdata.asmlists[al_procedures].concat(tai_const.createname('_FPCDummy',0));
+
+         { leave when we got an error }
+         if (Errorcount>0) and not status.skip_error then
+           begin
+             Message1(unit_f_errors_in_unit,tostr(Errorcount));
+             status.skip_error:=true;
+             exit;
+           end;
+
+         { remove all unused units, this happends when units are removed
+           from the uses clause in the source and the ppu was already being loaded }
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) do
+          begin
+            hp2:=hp;
+            hp:=tmodule(hp.next);
+            if hp2.is_unit and
+               not assigned(hp2.globalsymtable) then
+              loaded_units.remove(hp2);
+          end;
+
+         { force exports }
+         uu:=tused_unit(usedunits.first);
+         while assigned(uu) do
+           begin
+             uu.u.globalsymtable.symlist.ForEachCall(@insert_export,nil);
+             uu:=tused_unit(uu.next);
+           end;
+
+{$ifdef arm}
+         { Insert .pdata section for arm-wince.
+           It is needed for exception handling. }
+         if target_info.system in [system_arm_wince] then
+           InsertPData;
+{$endif arm}
+
+         { generate imports }
+         if current_module.ImportLibraryList.Count>0 then
+           importlib.generatelib;
+
+         { generate debuginfo }
+         if (cs_debuginfo in current_settings.moduleswitches) then
+           current_debuginfo.inserttypeinfo;
+
+         exportlib.generatelib;
+
+         { Reference all DEBUGINFO sections from the main .fpc section }
+         if (cs_debuginfo in current_settings.moduleswitches) then
+           current_debuginfo.referencesections(current_asmdata.asmlists[al_procedures]);
+
+         { insert own objectfile }
+         insertobjectfile;
+
+         { assemble and link }
+         create_objectfile;
+
+         { We might need the symbols info if not using
+           the default do_extractsymbolinfo
+           which is a dummy function PM }
+         needsymbolinfo:=do_extractsymbolinfo<>@def_extractsymbolinfo;
+         { release all local symtables that are not needed anymore }
+         if (not needsymbolinfo) then
+           free_localsymtables(current_module.localsymtable);
+
+         { leave when we got an error }
+         if (Errorcount>0) and not status.skip_error then
+          begin
+            Message1(unit_f_errors_in_unit,tostr(Errorcount));
+            status.skip_error:=true;
+            exit;
+          end;
+
+         if (not current_module.is_unit) then
+           begin
+             { create the executable when we are at level 1 }
+             if (compile_level=1) then
+               begin
+                 { create global resource file by collecting all resource files }
+                 CollectResourceFiles;
+                 { write .def file }
+                 if (cs_link_deffile in current_settings.globalswitches) then
+                   deffile.writefile;
+                 { 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 }
+                 hp:=tmodule(loaded_units.first);
+                 while assigned(hp) do
+                  begin
+                    { the package itself contains no code so far }
+                    linker.AddModuleFiles(hp);
+                    hp2:=tmodule(hp.next);
+                    if (hp<>current_module) and
+                       (not needsymbolinfo) then
+                      begin
+                        loaded_units.remove(hp);
+                        hp.free;
+                      end;
+                    hp:=hp2;
+                  end;
+                 linker.MakeSharedLibrary
+               end;
+
+             { Give Fatal with error count for linker errors }
+             if (Errorcount>0) and not status.skip_error then
+              begin
+                Message1(unit_f_errors_in_unit,tostr(Errorcount));
+                status.skip_error:=true;
+              end;
+          end;
+      end;
+
+
     procedure proc_program(islibrary : boolean);
       var
          main_file : tinputfile;
@@ -1198,6 +1499,7 @@ implementation
       begin
          DLLsource:=islibrary;
          Status.IsLibrary:=IsLibrary;
+         Status.IsPackage:=false;
          Status.IsExe:=true;
          parse_only:=false;
          main_procinfo:=nil;

compiler/systems/t_win.pas

@@ -638,7 +638,7 @@ implementation
 
     procedure TExportLibWin.exportprocedure(hp : texported_item);
       begin
-        if ((hp.options and eo_index)<>0)and((hp.index<=0) or (hp.index>$ffff)) then
+        if ((hp.options and eo_index)<>0) and ((hp.index<=0) or (hp.index>$ffff)) then
           begin
            message1(parser_e_export_invalid_index,tostr(hp.index));
            exit;
@@ -705,9 +705,9 @@ implementation
          autoindex:=1;
          while EList_nonindexed.Count>0 do
           begin
-           hole:=(EList_indexed.Count>0)and(texported_item(EList_indexed.Items[0]).index>1);
+           hole:=(EList_indexed.Count>0) and (texported_item(EList_indexed.Items[0]).index>1);
            if not hole then
-            for i:=autoindex to pred(EList_indexed.Count)do
+            for i:=autoindex to pred(EList_indexed.Count) do
              if texported_item(EList_indexed.Items[i]).index-texported_item(EList_indexed.Items[pred(i)]).index>1 then
               begin
                autoindex:=succ(texported_item(EList_indexed.Items[pred(i)]).index);
@@ -726,8 +726,8 @@ implementation
            texported_item(EList_indexed.Items[pred(AutoIndex)]).index:=autoindex;
           end;
          FreeAndNil(EList_nonindexed);
-         for i:=0 to pred(EList_indexed.Count)do
-          exportfromlist(texported_item(EList_indexed.Items[i]));
+         for i:=0 to pred(EList_indexed.Count) do
+           exportfromlist(texported_item(EList_indexed.Items[i]));
          FreeAndNil(EList_indexed);
 
          if (target_asm.id in [as_i386_masm,as_i386_tasm,as_i386_nasmwin32]) then
@@ -856,14 +856,19 @@ implementation
                    address_table.concat(Tai_const.Create_32bit(0));
                    inc(current_index);
                 end;
-              case hp.sym.typ of
-                staticvarsym :
-                  asmsym:=current_asmdata.RefAsmSymbol(tstaticvarsym(hp.sym).mangledname);
-                procsym :
-                  asmsym:=current_asmdata.RefAsmSymbol(tprocdef(tprocsym(hp.sym).ProcdefList[0]).mangledname);
-                else
-                  internalerror(200709272);
-              end;
+
+              { symbol known? then get a new name }
+              if assigned(hp.sym) then
+                case hp.sym.typ of
+                  staticvarsym :
+                    asmsym:=current_asmdata.RefAsmSymbol(tstaticvarsym(hp.sym).mangledname);
+                  procsym :
+                    asmsym:=current_asmdata.RefAsmSymbol(tprocdef(tprocsym(hp.sym).ProcdefList[0]).mangledname)
+                  else
+                    internalerror(200709272);
+                end
+              else
+                asmsym:=current_asmdata.RefAsmSymbol(hp.name^);
               address_table.concat(Tai_const.Create_rva_sym(asmsym));
               inc(current_index);
               hp:=texported_item(hp.next);