diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2003-11-20 10:54:03 +0100 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2003-11-20 10:54:03 +0100 |
| commit | 19f0526a54834612872e13e2650e9c1f8dface4f (patch) | |
| tree | 9ab2d4d0cdbbc9c975cf5fec2dfda695284b8754 /gcc/ada | |
| parent | 371e8c4f52b053f5920d36482d650d70b7e592c1 (diff) | |
| download | gcc-19f0526a54834612872e13e2650e9c1f8dface4f.zip gcc-19f0526a54834612872e13e2650e9c1f8dface4f.tar.gz gcc-19f0526a54834612872e13e2650e9c1f8dface4f.tar.bz2 | |
[multiple changes]
2003-11-19 Arnaud Charlet <charlet@act-europe.fr>
* gnatmem.adb: Clean up verbose output.
* gprcmd.adb: Change copyright to FSF.
2003-11-19 Vincent Celier <celier@gnat.com>
* symbols.adb: (Initialize): New parameters Reference, Symbol_Policy
and Version (ignored).
* symbols.ads: (Policy): New type
(Initialize): New parameter Reference, Symbol_Policy and
Library_Version.
Remove parameter Force.
Minor reformatting.
* snames.ads, snames.adbadb: New standard names
Library_Reference_Symbol_File and Library_Symbol_Policy
* mlib-prj.adb:
(Build_Library): Call Build_Dinamic_Library with the Symbol_Data of the
project.
* mlib-tgt.adb:
(Build_Dynamic_Library): New parameter Symbol_Data (ignored)
* mlib-tgt.ads: (Build_Dynamic_Library): New parameter Symbol_Data
* prj.adb: (Project_Empty): New component Symbol_Data
* prj.ads: (Policy, Symbol_Record): New types
(Project_Data): New component Symbol_Data
* prj-attr.adb:
New attributes Library_Symbol_File, Library_Symbol_Policy and
Library_Reference_Symbol_File.
* prj-nmsc.adb:
(Ada_Check): When project is a Stand-Alone library project, process
attribute Library_Symbol_File, Library_Symbol_Policy and
Library_Reference_Symbol_File.
* 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb,
5wml-tgt.adb, 5zml-tgt.adb, 5lml-tgt.adb,
5sml-tgt.adb (Build_Dynamic_Library): New parameter
Symbol_Data (ignored).
* 5vml-tgt.adb (VMS_Options): Remove --for-linker=gsmatch=equal,1,0
(Build_Dynamic_Library): New parameter Symbol_Data. New internal
functions Option_File_Name and Version_String. Set new options of
gnatsym related to symbol file, symbol policy and reference symbol
file.
* 5vsymbol.adb:
Extensive modifications to take into account the reference symbol file,
the symbol policy, the library version and to put in the symbol file the
minor and major IDs.
* bld.adb (Process_Declarative_Items): Put second argument of
gprcmd to_absolute between single quotes, to avoid problems with
Windows.
* bld-io.adb: Update Copyright notice.
(Flush): Remove last character of a line, if it is a back slash, to
avoid make problems.
* gnatsym.adb:
Implement new scheme with reference symbol file and symbol policy.
* g-os_lib.ads: (Is_Directory): Clarify comment
2003-11-19 Robert Dewar <dewar@gnat.com>
* atree.adb: Move New_Copy_Tree global variables to head of package
* errout.adb: Minor reformatting
2003-11-19 Javier Miranda <miranda@gnat.com>
* sem_ch4.adb: (Diagnose_Call): Improve error message.
Add reference to Ada0Y (AI-50217)
* sem_ch6.adb, sem_ch8.adb, sem_type.adb,
sem_util.adb: Add reference to AI-50217
* sinfo.ads: (N_With_Clause): Document fields referred to AI-50217
* sprint.adb: Add reference to Ada0Y (AI-50217, AI-287)
* sem_aggr.adb: Complete documentation of AI-287 changes
* par-ch4.adb: Document previous changes.
* lib-load.adb, lib-writ.adb, einfo.ads, par-ch10.adb,
sem_cat.adb, sem_ch3.adb, sem_ch10.adb, sem_ch12.adb: Add references to
Ada0Y (AI-50217)
* exp_aggr.adb: Add references to AI-287 in previous changes
2003-11-19 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb:
(Add_Call_By_Copy_Node): Do not original node of rewritten expression
in the rewriting is the result of an inlined call.
* exp_ch6.adb (Add_Call_By_Copy_Node): If actual for (in-)out
parameter is a type conversion, use original node to construct the
post-call assignment, because expression may have been rewritten, e.g.
if it is a packed array.
* sem_attr.adb:
(Resolve_Attribute, case 'Constrained): Attribute is legal in an inlined
body, just as it is in an instance.
Categorization routines
* sem_ch12.adb (Analyze_Association, Instantiate_Formal_Subprogram,
Instantiate_Object): Set proper sloc reference for message on missing
actual.
2003-11-19 Thomas Quinot <quinot@act-europe.fr>
* Makefile.in: Add FreeBSD libgnat pairs.
* usage.adb: Fix typo in usage message.
2003-11-19 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: On powerpc-wrs-vxworksae: Add s-thread.ad?,
s-thrini.ad? and s-tiitho.adb to the full runtime, to support the
pragma Thread_Body.
Remove i-vthrea.ad? and s-tpae65.ad?, not needed anymore.
* s-thread.adb: This file is now a dummy implementation of
System.Thread.
2003-11-19 Sergey Rybin <rybin@act-europe.fr>
* rtsfind.adb (Initialize): Add initialization for RTE_Is_Available
2003-11-19 Emmanuel Briot <briot@act-europe.fr>
* xref_lib.adb (Parse_Identifier_Info): Add handling of generic
instanciation references in the parent type description.
From-SVN: r73757
Diffstat (limited to 'gcc/ada')
55 files changed, 1187 insertions, 326 deletions
diff --git a/gcc/ada/5aml-tgt.adb b/gcc/ada/5aml-tgt.adb index 60e998e..69385b6 100644 --- a/gcc/ada/5aml-tgt.adb +++ b/gcc/ada/5aml-tgt.adb @@ -108,6 +108,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -117,6 +118,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5bml-tgt.adb b/gcc/ada/5bml-tgt.adb index 59c6d56..c07d58c 100644 --- a/gcc/ada/5bml-tgt.adb +++ b/gcc/ada/5bml-tgt.adb @@ -120,6 +120,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -129,6 +130,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Lib_Version); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5gml-tgt.adb b/gcc/ada/5gml-tgt.adb index 027ae8a..c5390a6 100644 --- a/gcc/ada/5gml-tgt.adb +++ b/gcc/ada/5gml-tgt.adb @@ -103,6 +103,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -112,6 +113,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5hml-tgt.adb b/gcc/ada/5hml-tgt.adb index 5398d56..c790df8 100644 --- a/gcc/ada/5hml-tgt.adb +++ b/gcc/ada/5hml-tgt.adb @@ -102,6 +102,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -111,6 +112,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb index ad40c10..b9d4217 100644 --- a/gcc/ada/5lml-tgt.adb +++ b/gcc/ada/5lml-tgt.adb @@ -106,6 +106,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -115,6 +116,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5sml-tgt.adb b/gcc/ada/5sml-tgt.adb index 901e7a6..a7bc933 100644 --- a/gcc/ada/5sml-tgt.adb +++ b/gcc/ada/5sml-tgt.adb @@ -100,6 +100,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -109,6 +110,7 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb index 3dba336..269e8b0 100644 --- a/gcc/ada/5vml-tgt.adb +++ b/gcc/ada/5vml-tgt.adb @@ -59,13 +59,9 @@ package body MLib.Tgt is -- Options to use when invoking gcc to build the dynamic library No_Start_Files : aliased String := "-nostartfiles"; - For_Linker_Opt : aliased String := "--for-linker=symvec.opt"; - Gsmatch : aliased String := "--for-linker=gsmatch=equal,1,0"; - VMS_Options : constant Argument_List := - (No_Start_Files'Access, For_Linker_Opt'Access, Gsmatch'Access); - --- Command : String_Access; + VMS_Options : Argument_List := + (No_Start_Files'Access, null); Gnatsym_Name : constant String := "gnatsym"; @@ -134,6 +130,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -143,10 +140,9 @@ package body MLib.Tgt is pragma Unreferenced (Foreign); pragma Unreferenced (Afiles); pragma Unreferenced (Lib_Address); - pragma Unreferenced (Lib_Version); pragma Unreferenced (Relocatable); - Opt_File_Name : constant String := "symvec.opt"; + Lib_File : constant String := Lib_Dir & Directory_Separator & "lib" & @@ -163,6 +159,13 @@ package body MLib.Tgt is -- file name of an interface of the SAL. -- For other libraries, always return True. + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty, otherwise returns "1". + -- Fails gnatmake if Lib_Version is not the image of a positive number. + ------------------ -- Is_Interface -- ------------------ @@ -192,7 +195,57 @@ package body MLib.Tgt is end if; end Is_Interface; + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Name then + return "symvec.opt"; + + else + return Get_Name_String (Symbol_Data.Symbol_File); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + begin + if Lib_Version = "" then + return "1"; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """, Lib_Version, + """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + Opt_File_Name : constant String := Option_File_Name; + For_Linker_Opt : constant String_Access := + new String'("--for-linker=" & Opt_File_Name); + Version : constant String := Version_String; + begin + VMS_Options (VMS_Options'First + 1) := For_Linker_Opt; + for J in Inter'Range loop To_Lower (Inter (J).all); end loop; @@ -288,19 +341,61 @@ package body MLib.Tgt is end; end if; - -- Allocate the argument list and put the symbol file name + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). - Arguments := new Argument_List (1 .. Ofiles'Length + 2); + Arguments := new Argument_List (1 .. Ofiles'Length + 8); - Last_Argument := 1; + Last_Argument := 0; + + -- Verbosity if Verbose_Mode then + Last_Argument := Last_Argument + 1; Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); end if; + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; Arguments (Last_Argument) := new String'(Opt_File_Name); + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Name then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + end case; + -- Add each relevant object file for Index in Ofiles'Range loop diff --git a/gcc/ada/5vsymbol.adb b/gcc/ada/5vsymbol.adb index d505491..c623e42 100644 --- a/gcc/ada/5vsymbol.adb +++ b/gcc/ada/5vsymbol.adb @@ -36,10 +36,32 @@ package body Symbols is Symbol_Vector : constant String := "SYMBOL_VECTOR=("; Equal_Data : constant String := "=DATA)"; Equal_Procedure : constant String := "=PROCEDURE)"; + Gsmatch : constant String := "gsmatch=equal,"; Symbol_File_Name : String_Access := null; -- Name of the symbol file + Sym_Policy : Policy := Autonomous; + -- The symbol policy. Set by Initialize + + Major_ID : Integer := 1; + -- The Major ID. May be modified by Initialize if Library_Version is + -- specified or if it is read from the reference symbol file. + + Soft_Major_ID : Boolean := True; + -- False if library version is specified in procedure Initialize. + -- When True, Major_ID may be modified if found in the reference symbol + -- file. + + Minor_ID : Natural := 0; + -- The Minor ID. May be modified if read from the reference symbol file + + Soft_Minor_ID : Boolean := True; + -- False if symbol policy is Autonomous, if library version is specified + -- in procedure Initialize and is not the same as the major ID read from + -- the reference symbol file. When True, Minor_ID may be increased in + -- Compliant symbol policy. + subtype Byte is Character; -- Object files are stream of bytes, but some of these bytes, those for -- the names of the symbols, are ASCII characters. @@ -67,6 +89,9 @@ package body Symbols is Number_Of_Characters : Natural := 0; -- The number of characters of each section + -- The following variables are used by procedure Process when reading an + -- object file. + Code : Number := 0; Length : Natural := 0; @@ -87,6 +112,10 @@ package body Symbols is procedure Get (N : out Natural); -- Read two bytes from the object file, LSByte first, as a Natural + + function Image (N : Integer) return String; + -- Returns the image of N, without the initial space + ----------- -- Equal -- ----------- @@ -121,15 +150,32 @@ package body Symbols is N := Natural (Result); end Get; + ----------- + -- Image -- + ----------- + + function Image (N : Integer) return String is + Result : constant String := N'Img; + begin + if Result (Result'First) = ' ' then + return Result (Result'First + 1 .. Result'Last); + + else + return Result; + end if; + end Image; + ---------------- -- Initialize -- ---------------- procedure Initialize - (Symbol_File : String; - Force : Boolean; - Quiet : Boolean; - Success : out Boolean) + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) is File : Ada.Text_IO.File_Type; Line : String (1 .. 1_000); @@ -140,6 +186,40 @@ package body Symbols is Symbol_File_Name := new String'(Symbol_File); + -- Record the policy + + Sym_Policy := Symbol_Policy; + + -- Record the version (Major ID) + + if Version = "" then + Major_ID := 1; + Soft_Major_ID := True; + + else + begin + Major_ID := Integer'Value (Version); + Soft_Major_ID := False; + + if Major_ID <= 0 then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + if not Quiet then + Put_Line ("Version """ & Version & """ is illegal."); + Put_Line ("On VMS, version must be a positive number"); + end if; + + Success := False; + return; + end; + end if; + + Minor_ID := 0; + Soft_Minor_ID := Sym_Policy /= Autonomous; + -- Empty the symbol tables Symbol_Table.Set_Last (Original_Symbols, 0); @@ -149,11 +229,11 @@ package body Symbols is Success := True; - -- If Force is not set, attempt to read the symbol file + -- If policy is not autonomous, attempt to read the reference file - if not Force then + if Sym_Policy /= Autonomous then begin - Open (File, In_File, Symbol_File); + Open (File, In_File, Reference); exception when Ada.Text_IO.Name_Error => @@ -161,7 +241,7 @@ package body Symbols is when X : others => if not Quiet then - Put_Line ("could not open """ & Symbol_File & """"); + Put_Line ("could not open """ & Reference & """"); Put_Line (Exception_Message (X)); end if; @@ -169,20 +249,31 @@ package body Symbols is return; end; + -- Read line by line + while not End_Of_File (File) loop Get_Line (File, Line, Last); + -- Ignore empty lines + if Last = 0 then null; + -- Ignore lines starting with "case_sensitive=" + elsif Last > Case_Sensitive'Length and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive then null; + -- Line starting with "SYMBOL_VECTOR=(" + elsif Last > Symbol_Vector'Length and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector then + + -- SYMBOL_VECTOR=(<symbol>=DATA) + if Last > Symbol_Vector'Length + Equal_Data'Length and then Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data then @@ -195,6 +286,8 @@ package body Symbols is Kind => Data, Present => True); + -- SYMBOL_VECTOR=(<symbol>=PROCEDURE) + elsif Last > Symbol_Vector'Length + Equal_Procedure'Length and then Line (Last - Equal_Procedure'Length + 1 .. Last) = @@ -209,9 +302,11 @@ package body Symbols is Kind => Proc, Present => True); + -- Anything else is incorrectly formatted + else if not Quiet then - Put_Line ("symbol file """ & Symbol_File & + Put_Line ("symbol file """ & Reference & """ is incorrectly formatted:"); Put_Line ("""" & Line (1 .. Last) & """"); end if; @@ -221,10 +316,95 @@ package body Symbols is return; end if; + -- Lines with "gsmatch=equal,<Major_ID>,<Minor_Id> + + elsif Last > Gsmatch'Length + and then Line (1 .. Gsmatch'Length) = Gsmatch + then + declare + Start : Positive := Gsmatch'Length + 1; + Finish : Positive := Start; + OK : Boolean := True; + ID : Integer; + + begin + loop + if Line (Finish) not in '0' .. '9' + or else Finish >= Last - 1 + then + OK := False; + exit; + end if; + + exit when Line (Finish + 1) = ','; + + Finish := Finish + 1; + end loop; + + if OK then + ID := Integer'Value (Line (Start .. Finish)); + OK := ID /= 0; + + -- If Soft_Major_ID is True, it means that + -- Library_Version was not specified. + + if Soft_Major_ID then + Major_ID := ID; + + -- If the Major ID in the reference file is different + -- from the Library_Version, then the Minor ID will be 0 + -- because there is no point in taking the Minor ID in + -- the reference file, or incrementing it. So, we set + -- Soft_Minor_ID to False, so that we don't modify + -- the Minor_ID later. + + elsif Major_ID /= ID then + Soft_Minor_ID := False; + end if; + + Start := Finish + 2; + Finish := Start; + + loop + if Line (Finish) not in '0' .. '9' then + OK := False; + exit; + end if; + + exit when Finish = Last; + + Finish := Finish + 1; + end loop; + + -- Only set Minor_ID if Soft_Minor_ID is True (see above) + + if OK and then Soft_Minor_ID then + Minor_ID := Integer'Value (Line (Start .. Finish)); + end if; + end if; + + -- If OK is not True, that means the line is not correctly + -- formatted. + + if not OK then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end; + + -- Anything else is incorrectly formatted + else if not Quiet then Put_Line ("unexpected line in symbol file """ & - Symbol_File & """"); + Reference & """"); Put_Line ("""" & Line (1 .. Last) & """"); end if; @@ -247,7 +427,8 @@ package body Symbols is Success : out Boolean) is begin - -- Open the object file. Return with Success = False if this fails. + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. begin Open (File, In_File, Object_File); @@ -410,8 +591,9 @@ package body Symbols is else - -- First find if the symbols in the symbol file are also in the - -- object files. + -- First find if the symbols in the reference symbol file are also + -- in the object files. Note that this is not done if the policy is + -- Autonomous, because no reference symbol file has been read. -- Expect the first symbol in the symbol file to also be the first -- in Complete_Symbols. @@ -450,13 +632,27 @@ package body Symbols is -- If the symbol is not found, mark it as such in the table if not Found then - if not Quiet then + if (not Quiet) or else Sym_Policy = Controlled then Put_Line ("symbol """ & S_Data.Name.all & """ is no longer present in the object files"); end if; + if Sym_Policy = Controlled then + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + Original_Symbols.Table (Index_1).Present := False; Free (Original_Symbols.Table (Index_1).Name); + + if Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; end if; end loop; @@ -466,6 +662,18 @@ package body Symbols is S_Data := Complete_Symbols.Table (Index); if S_Data.Present then + + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + Symbol_Table.Increment_Last (Original_Symbols); Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := S_Data; @@ -501,6 +709,13 @@ package body Symbols is Put (File, Case_Sensitive); Put_Line (File, "NO"); + -- Put the version IDs + + Put (File, Gsmatch); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); + -- And we are done Close (File); diff --git a/gcc/ada/5wml-tgt.adb b/gcc/ada/5wml-tgt.adb index ffb3b2a..5747ead 100644 --- a/gcc/ada/5wml-tgt.adb +++ b/gcc/ada/5wml-tgt.adb @@ -91,6 +91,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -99,6 +100,7 @@ package body MLib.Tgt is is pragma Unreferenced (Ofiles); pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Driver_Name); pragma Unreferenced (Lib_Version); pragma Unreferenced (Auto_Init); diff --git a/gcc/ada/5zml-tgt.adb b/gcc/ada/5zml-tgt.adb index 7016a22..0331c9f 100644 --- a/gcc/ada/5zml-tgt.adb +++ b/gcc/ada/5zml-tgt.adb @@ -93,6 +93,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -106,6 +107,7 @@ package body MLib.Tgt is pragma Unreferenced (Interfaces); pragma Unreferenced (Lib_Filename); pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Driver_Name); pragma Unreferenced (Lib_Address); pragma Unreferenced (Lib_Version); diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 49bb480..ac5254f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,148 @@ +2003-11-19 Arnaud Charlet <charlet@act-europe.fr> + + * gnatmem.adb: Clean up verbose output. + + * gprcmd.adb: Change copyright to FSF. + +2003-11-19 Vincent Celier <celier@gnat.com> + + * symbols.adb: (Initialize): New parameters Reference, Symbol_Policy + and Version (ignored). + + * symbols.ads: (Policy): New type + (Initialize): New parameter Reference, Symbol_Policy and + Library_Version. + Remove parameter Force. + Minor reformatting. + + * snames.ads, snames.adbadb: New standard names + Library_Reference_Symbol_File and Library_Symbol_Policy + + * mlib-prj.adb: + (Build_Library): Call Build_Dinamic_Library with the Symbol_Data of the + project. + + * mlib-tgt.adb: + (Build_Dynamic_Library): New parameter Symbol_Data (ignored) + + * mlib-tgt.ads: (Build_Dynamic_Library): New parameter Symbol_Data + + * prj.adb: (Project_Empty): New component Symbol_Data + + * prj.ads: (Policy, Symbol_Record): New types + (Project_Data): New component Symbol_Data + + * prj-attr.adb: + New attributes Library_Symbol_File, Library_Symbol_Policy and + Library_Reference_Symbol_File. + + * prj-nmsc.adb: + (Ada_Check): When project is a Stand-Alone library project, process + attribute Library_Symbol_File, Library_Symbol_Policy and + Library_Reference_Symbol_File. + + * 5aml-tgt.adb, 5bml-tgt.adb, 5gml-tgt.adb, 5hml-tgt.adb, + 5wml-tgt.adb, 5zml-tgt.adb, 5lml-tgt.adb, + 5sml-tgt.adb (Build_Dynamic_Library): New parameter + Symbol_Data (ignored). + + * 5vml-tgt.adb (VMS_Options): Remove --for-linker=gsmatch=equal,1,0 + (Build_Dynamic_Library): New parameter Symbol_Data. New internal + functions Option_File_Name and Version_String. Set new options of + gnatsym related to symbol file, symbol policy and reference symbol + file. + + * 5vsymbol.adb: + Extensive modifications to take into account the reference symbol file, + the symbol policy, the library version and to put in the symbol file the + minor and major IDs. + + * bld.adb (Process_Declarative_Items): Put second argument of + gprcmd to_absolute between single quotes, to avoid problems with + Windows. + + * bld-io.adb: Update Copyright notice. + (Flush): Remove last character of a line, if it is a back slash, to + avoid make problems. + + * gnatsym.adb: + Implement new scheme with reference symbol file and symbol policy. + + * g-os_lib.ads: (Is_Directory): Clarify comment + +2003-11-19 Robert Dewar <dewar@gnat.com> + + * atree.adb: Move New_Copy_Tree global variables to head of package + + * errout.adb: Minor reformatting + +2003-11-19 Javier Miranda <miranda@gnat.com> + + * sem_ch4.adb: (Diagnose_Call): Improve error message. + Add reference to Ada0Y (AI-50217) + + * sem_ch6.adb, sem_ch8.adb, sem_type.adb, + sem_util.adb: Add reference to AI-50217 + + * sinfo.ads: (N_With_Clause): Document fields referred to AI-50217 + + * sprint.adb: Add reference to Ada0Y (AI-50217, AI-287) + + * sem_aggr.adb: Complete documentation of AI-287 changes + + * par-ch4.adb: Document previous changes. + + * lib-load.adb, lib-writ.adb, einfo.ads, par-ch10.adb, + sem_cat.adb, sem_ch3.adb, sem_ch10.adb, sem_ch12.adb: Add references to + Ada0Y (AI-50217) + + * exp_aggr.adb: Add references to AI-287 in previous changes + +2003-11-19 Ed Schonberg <schonberg@gnat.com> + + * exp_ch6.adb: + (Add_Call_By_Copy_Node): Do not original node of rewritten expression + in the rewriting is the result of an inlined call. + + * exp_ch6.adb (Add_Call_By_Copy_Node): If actual for (in-)out + parameter is a type conversion, use original node to construct the + post-call assignment, because expression may have been rewritten, e.g. + if it is a packed array. + + * sem_attr.adb: + (Resolve_Attribute, case 'Constrained): Attribute is legal in an inlined + body, just as it is in an instance. + Categorization routines + + * sem_ch12.adb (Analyze_Association, Instantiate_Formal_Subprogram, + Instantiate_Object): Set proper sloc reference for message on missing + actual. + +2003-11-19 Thomas Quinot <quinot@act-europe.fr> + + * Makefile.in: Add FreeBSD libgnat pairs. + + * usage.adb: Fix typo in usage message. + +2003-11-19 Jerome Guitton <guitton@act-europe.fr> + + * Makefile.in: On powerpc-wrs-vxworksae: Add s-thread.ad?, + s-thrini.ad? and s-tiitho.adb to the full runtime, to support the + pragma Thread_Body. + Remove i-vthrea.ad? and s-tpae65.ad?, not needed anymore. + + * s-thread.adb: This file is now a dummy implementation of + System.Thread. + +2003-11-19 Sergey Rybin <rybin@act-europe.fr> + + * rtsfind.adb (Initialize): Add initialization for RTE_Is_Available + +2003-11-19 Emmanuel Briot <briot@act-europe.fr> + + * xref_lib.adb (Parse_Identifier_Info): Add handling of generic + instanciation references in the parent type description. + 2003-11-18 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * ada-tree.def: (ALLOCATE_EXPR): Class is "2", not "s". diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 8ccce71..66956a9 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -626,6 +626,10 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) s-parame.ads<5yparame.ads \ s-taprop.adb<5ztaprop.adb \ s-taspri.ads<5ztaspri.ads \ + s-thread.adb<5zthread.adb \ + s-thrini.ads<2sthrini.ads \ + s-thrini.adb<5zthrini.adb \ + s-tiitho.adb<5ytiitho.adb \ s-tpopsp.adb<5ztpopsp.adb \ s-vxwork.ads<5pvxwork.ads \ g-soccon.ads<3zsoccon.ads \ @@ -640,8 +644,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o - EXTRA_GNATRTL_TASKING_OBJS=i-vthrea.o s-tpae65.o s-vxwork.o + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o s-thrini.o + EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o HIE_RAVEN_TARGET_PAIRS=\ $(HIE_NONE_TARGET_PAIRS) \ a-reatim.ads<1areatim.ads \ @@ -688,6 +692,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) s-soflin.ads<2ssoflin.ads \ s-stalib.adb<1sstalib.adb \ s-stalib.ads<1sstalib.ads \ + s-thrini.adb<5zthrini.adb \ s-thrini.ads<2sthrini.ads \ s-thrini.adb<5zthrini.adb \ s-tiitho.adb<5ytiitho.adb \ @@ -966,6 +971,25 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) endif endif +ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads<45intnam.ads \ + g-soccon.ads<35soccon.ads \ + s-inmaop.adb<7sinmaop.adb \ + s-intman.adb<7sintman.adb \ + s-mastop.adb<5omastop.adb \ + s-osinte.adb<55osinte.adb \ + s-osinte.ads<55osinte.ads \ + s-osprim.adb<7sosprim.adb \ + s-taprop.adb<7staprop.adb \ + s-taspri.ads<7staspri.ads \ + s-tpopsp.adb<7stpopsp.adb \ + system.ads<56system.ads + + THREADSLIB= + LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) +endif + ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),) LIBGNAT_TARGET_PAIRS = \ diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 50647da..bc4fb13 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -347,6 +347,35 @@ package body Atree is Table_Increment => Alloc.Orig_Nodes_Increment, Table_Name => "Orig_Nodes"); + ---------------------------------------- + -- Global_Variables for New_Copy_Tree -- + ---------------------------------------- + + -- These global variables are used by New_Copy_Tree. See description + -- of the body of this subprogram for details. Global variables can be + -- safely used by New_Copy_Tree, since there is no case of a recursive + -- call from the processing inside New_Copy_Tree. + + NCT_Hash_Threshhold : constant := 20; + -- If there are more than this number of pairs of entries in the + -- map, then Hash_Tables_Used will be set, and the hash tables will + -- be initialized and used for the searches. + + NCT_Hash_Tables_Used : Boolean := False; + -- Set to True if hash tables are in use + + NCT_Table_Entries : Nat; + -- Count entries in table to see if threshhold is reached + + NCT_Hash_Table_Setup : Boolean := False; + -- Set to True if hash table contains data. We set this True if we + -- setup the hash table with data, and leave it set permanently + -- from then on, this is a signal that second and subsequent users + -- of the hash table must clear the old entries before reuse. + + subtype NCT_Header_Num is Int range 0 .. 511; + -- Defines range of headers in hash tables (512 headers) + ----------------------- -- Local Subprograms -- ----------------------- @@ -959,29 +988,6 @@ package body Atree is -- (because setting up a hash table for only a few entries takes -- more time than it saves. - -- Global variables are safe for this purpose, since there is no case - -- of a recursive call from the processing inside New_Copy_Tree. - - NCT_Hash_Threshhold : constant := 20; - -- If there are more than this number of pairs of entries in the - -- map, then Hash_Tables_Used will be set, and the hash tables will - -- be initialized and used for the searches. - - NCT_Hash_Tables_Used : Boolean := False; - -- Set to True if hash tables are in use - - NCT_Table_Entries : Nat; - -- Count entries in table to see if threshhold is reached - - NCT_Hash_Table_Setup : Boolean := False; - -- Set to True if hash table contains data. We set this True if we - -- setup the hash table with data, and leave it set permanently - -- from then on, this is a signal that second and subsequent users - -- of the hash table must clear the old entries before reuse. - - subtype NCT_Header_Num is Int range 0 .. 511; - -- Defines range of headers in hash tables (512 headers) - function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num; -- Hash function used for hash operations diff --git a/gcc/ada/bld-io.adb b/gcc/ada/bld-io.adb index 51c14cb..7bd01e6 100644 --- a/gcc/ada/bld-io.adb +++ b/gcc/ada/bld-io.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -132,6 +132,7 @@ package body Bld.IO is ----------- procedure Flush is + Last : Natural; begin if Lines (Current).Length /= 0 then Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ & @@ -141,7 +142,18 @@ package body Bld.IO is for J in 1 .. Current - 1 loop if not Lines (J).Suppressed then - Text_IO.Put_Line (File, Lines (J).Value (1 .. Lines (J).Length)); + Last := Lines (J).Length; + + -- The last character of a line cannot be a back slash ('\'), + -- otherwise make has a problem. The only real place were it + -- should happen is for directory names on Windows, and then + -- this terminal back slash is not needed. + + if Last > 0 and then Lines (J).Value (Last) = '\' then + Last := Last - 1; + end if; + + Text_IO.Put_Line (File, Lines (J).Value (1 .. Last)); end if; end loop; diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb index 725e9ca..d8cf51c 100644 --- a/gcc/ada/bld.adb +++ b/gcc/ada/bld.adb @@ -40,7 +40,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Erroutc; use Erroutc; with Err_Vars; use Err_Vars; -with Gnatvsn; +with Gnatvsn; use Gnatvsn; with Namet; use Namet; with Opt; use Opt; with Output; use Output; @@ -1559,9 +1559,9 @@ package body Bld is Put ("src.list_file:=" & "$(strip $(shell gprcmd to_absolute $("); Put (Project_Name); - Put (".base_dir) $("); + Put (".base_dir) '$("); Put_Attribute (Project, Pkg, Item_Name, No_Name); - Put_Line (")))"); + Put_Line (")'))"); if In_Case then if Source_List_File_Declaration = False then @@ -1595,9 +1595,9 @@ package body Bld is Put (".obj_dir:=" & "$(strip $(shell gprcmd to_absolute $("); Put (Project_Name); - Put (".base_dir) $("); + Put (".base_dir) '$("); Put_Attribute (Project, Pkg, Item_Name, No_Name); - Put_Line (")))"); + Put_Line (")'))"); elsif Item_Name = Snames.Name_Exec_Dir then @@ -1611,9 +1611,9 @@ package body Bld is Put ("EXEC_DIR:=" & "$(strip $(shell gprcmd to_absolute $("); Put (Project_Name); - Put (".base_dir) $("); + Put (".base_dir) '$("); Put_Attribute (Project, Pkg, Item_Name, No_Name); - Put_Line (")))"); + Put_Line (")'))"); elsif Item_Name = Snames.Name_Main then diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 59ff1ad..07aa13f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1162,6 +1162,9 @@ package Einfo is -- types, i.e. record types (Java classes) that hold pointers to each -- other. If such a type is an access type, it has no explicit freeze -- node, so that the back-end does not attempt to elaborate it. +-- Currently this flag is also used to implement Ada0Y (AI-50217). +-- It will be renamed to From_Limited_With after removal of the current +-- GNAT with_type clause??? -- Full_View (Node11) -- Present in all type and subtype entities and in deferred constants. @@ -2385,7 +2388,7 @@ package Einfo is -- Present in non-generic package entities that are not instances. -- The elements of this list are the shadow entities created for the -- types and local packages that are declared in a package that appears --- in a limited_with clause. +-- in a limited_with clause (Ada0Y: AI-50217) -- Lit_Indexes (Node15) -- Present in enumeration types and subtypes. Non-empty only for the @@ -2554,9 +2557,9 @@ package Einfo is -- is other than a power of 2. -- Non_Limited_View (Node17) --- Present in incomplete types that are the shadow entities --- created when analyzing a limited_with_clause. Points to the --- definining entity in the original declaration. +-- Present in incomplete types that are the shadow entities created +-- when analyzing a limited_with_clause (Ada0Y: AI-50217). Points to +-- the defining entity in the original declaration. -- Nonzero_Is_True (Flag162) [base type only] -- Present in enumeration types. True if any non-zero value is to be diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 5183289..fb1cc76 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1409,11 +1409,11 @@ package body Errout is Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; end if; - -- Set all (???) the error nodes to Empty: + -- Set the error nodes to Empty to avoid uninitialized variable + -- references for saves/restores/moves. Error_Msg_Node_1 := Empty; Error_Msg_Node_2 := Empty; - end Initialize; ----------------- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 0f6c2ee..cf24a629 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -71,8 +71,8 @@ package body Exp_Aggr is -- sorted order. function Has_Default_Init_Comps (N : Node_Id) return Boolean; - -- N is an aggregate (record or array). Checks the presence of - -- default initialization (<>) in any component. + -- N is an aggregate (record or array). Checks the presence of default + -- initialization (<>) in any component (Ada0Y: AI-287) ------------------------------------------------------ -- Local subprograms for Record Aggregate Expansion -- @@ -1540,8 +1540,8 @@ package body Exp_Aggr is Selector_Name => Make_Identifier (Loc, Name_uController)); Set_Assignment_OK (Ref); - -- Give support to default initialization of limited types and - -- components + -- Ada0Y (AI-287): Give support to default initialization of limited + -- types and components if (Nkind (Target) = N_Identifier and then Is_Limited_Type (Etype (Target))) @@ -1678,8 +1678,8 @@ package body Exp_Aggr is Check_Ancestor_Discriminants (Entity (A)); end if; - -- If the ancestor part is a limited type, a recursive call - -- expands the ancestor. + -- Ada0Y (AI-287): If the ancestor part is a limited type, a + -- recursive call expands the ancestor. elsif Is_Limited_Type (Etype (A)) then Ancestor_Is_Expression := True; @@ -4145,6 +4145,9 @@ package body Exp_Aggr is then Convert_To_Assignments (N, Typ); + -- Ada0Y (AI-287): In case of default initialized components we convert + -- the aggregate into assignments. + elsif Has_Default_Init_Comps (N) then Convert_To_Assignments (N, Typ); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 5ac60af..15730c7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -541,7 +541,28 @@ package body Exp_Ch6 is if Nkind (Actual) = N_Type_Conversion then V_Typ := Etype (Expression (Actual)); - Var := Make_Var (Expression (Actual)); + + -- If the formal is an (in-)out parameter, capture the name + -- of the variable in order to build the post-call assignment. + -- The variable itself may have been expanded, for example if + -- it is a complex bit-packed array, so we need to recover the + -- original to ensure that we have the proper target for the + -- assignment. Examine the slocs of the two nodes to determine + -- whether the rewriting is an expansion, or a substitution done + -- on an inlined body, in which case it must be respected. + + declare + Orig : constant Node_Id := Original_Node (Expression (Actual)); + begin + if Orig /= Expression (Actual) + and then Sloc (Orig) = Sloc (Expression (Actual)) + then + Var := Make_Var (Orig); + else + Var := Make_Var (Expression (Actual)); + end if; + end; + Crep := not Same_Representation (Etype (Formal), Etype (Expression (Actual))); else diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index f7cf85b..0e1af2a 100644 --- a/gcc/ada/g-os_lib.ads +++ b/gcc/ada/g-os_lib.ads @@ -416,15 +416,21 @@ pragma Elaborate_Body (OS_Lib); function Is_Absolute_Path (Name : String) return Boolean; -- Returns True if Name is an absolute path name, i.e. it designates - -- a directory absolutely, rather than relative to another directory. + -- a file or a directory absolutely, rather than relative to another + -- directory. function Is_Regular_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing - -- regular file. Returns True if so, False otherwise. + -- regular file. Returns True if so, False otherwise. Name may be an + -- absolute path name or a relative path name, including a simple file + -- name. If it is a relative path name, it is relative to the current + -- working directory. function Is_Directory (Name : String) return Boolean; -- Determines if the given string, Name, is the name of a directory. - -- Returns True if so, False otherwise. + -- Returns True if so, False otherwise. Name may be an absolute path + -- name or a relative path name, including a simple file name. If it is + -- a relative path name, it is relative to the current working directory. function Is_Readable_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb index a852b26..8deca2e 100644 --- a/gcc/ada/gnatmem.adb +++ b/gcc/ada/gnatmem.adb @@ -228,7 +228,7 @@ procedure Gnatmem is procedure Usage is begin New_Line; - Put ("GNATMEM Pro "); + Put ("GNATMEM "); Put (Gnat_Version_String); Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc."); New_Line; diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb index b5523f8..a15cb6d 100644 --- a/gcc/ada/gnatsym.adb +++ b/gcc/ada/gnatsym.adb @@ -37,7 +37,9 @@ -- only on OpenVMS. -- gnatsym takes as parameters: --- - the name of the symbol file to create or update +-- - the name of the symbol file to create +-- - (optional) the policy to create the symbol file +-- - (optional) the name of the reference symbol file -- - the names of one or more object files where the symbols are found with GNAT.Command_Line; use GNAT.Command_Line; @@ -52,13 +54,16 @@ with Table; procedure Gnatsym is + Empty_String : aliased String := ""; + Empty : constant String_Access := Empty_String'Unchecked_Access; + -- To initialize variables Reference and Version_String + Copyright_Displayed : Boolean := False; -- A flag to prevent multiple display of the Copyright notice Success : Boolean := True; - Force : Boolean := False; - -- True when -f switcxh is used + Symbol_Policy : Policy := Autonomous; Verbose : Boolean := False; -- True when -v switch is used @@ -66,9 +71,15 @@ procedure Gnatsym is Quiet : Boolean := False; -- True when -q switch is used - Symbol_File_Name : String_Access; + Symbol_File_Name : String_Access := null; -- The name of the symbol file + Reference_Symbol_File_Name : String_Access := Empty; + -- The name of the reference symbol file + + Version_String : String_Access := Empty; + -- The version of the library. Used on VMS. + package Object_Files is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Natural, @@ -113,19 +124,32 @@ procedure Gnatsym is procedure Parse_Cmd_Line is begin loop - case GNAT.Command_Line.Getopt ("f q v") is + case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is when ASCII.NUL => exit; - when 'f' => - Force := True; + when 'c' => + Symbol_Policy := Compliant; + + when 'C' => + Symbol_Policy := Controlled; when 'q' => Quiet := True; + when 'r' => + Reference_Symbol_File_Name := + new String'(GNAT.Command_Line.Parameter); + + when 's' => + Symbol_File_Name := new String'(GNAT.Command_Line.Parameter); + when 'v' => Verbose := True; + when 'V' => + Version_String := new String'(GNAT.Command_Line.Parameter); + when others => Fail ("invalid switch: ", Full_Switch); end case; @@ -141,13 +165,8 @@ procedure Gnatsym is begin exit when S'Length = 0; - if Symbol_File_Name = null then - Symbol_File_Name := S; - - else - Object_Files.Increment_Last; - Object_Files.Table (Object_Files.Last) := S; - end if; + Object_Files.Increment_Last; + Object_Files.Table (Object_Files.Last) := S; end; end loop; exception @@ -162,11 +181,17 @@ procedure Gnatsym is procedure Usage is begin - Write_Line ("gnatsym [options] sym_file object_file {object_file}"); + Write_Line ("gnatsym [options] object_file {object_file}"); Write_Eol; - Write_Line (" -f Force generation of symbol file"); - Write_Line (" -q Quiet mode"); - Write_Line (" -v Verbose mode"); + Write_Line (" -c Compliant policy"); + Write_Line (" -C Controlled policy"); + Write_Line (" -q Quiet mode"); + Write_Line (" -r<ref> Reference symbol file name"); + Write_Line (" -s<sym> Symbol file name"); + Write_Line (" -v Verbose mode"); + Write_Line (" -V<ver> Version"); + Write_Eol; + Write_Line ("Specifying a symbol file with -s<sym> is compulsory"); Write_Eol; end Usage; @@ -188,7 +213,7 @@ begin -- If there is no symbol file or no object files on the command line, -- display the usage and exit with an error status. - if Object_Files.Last = 0 then + if Symbol_File_Name = null or else Object_Files.Last = 0 then Usage; OS_Exit (1); @@ -199,9 +224,16 @@ begin Write_Line (""""); end if; - -- Initialize the symbol file + -- Initialize the symbol file and, if specified, read the reference + -- file. - Symbols.Initialize (Symbol_File_Name.all, Force, Quiet, Success); + Symbols.Initialize + (Symbol_File => Symbol_File_Name.all, + Reference => Reference_Symbol_File_Name.all, + Symbol_Policy => Symbol_Policy, + Quiet => Quiet, + Version => Version_String.all, + Success => Success); -- Process the object files in order. Stop as soon as there is -- something wrong. @@ -232,6 +264,8 @@ begin Finalize (Quiet, Success); end if; + -- Fail if there was anything wrong + if not Success then Fail ("unable to build symbol file"); end if; diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb index 5cefb3b..0757f47 100644 --- a/gcc/ada/gprcmd.adb +++ b/gcc/ada/gprcmd.adb @@ -55,7 +55,7 @@ procedure Gprcmd is Version : constant String := "GPRCMD " & Gnatvsn.Gnat_Version_String & - " Copyright 2002-2003, Ada Core Technologies Inc."; + " Copyright 2002-2003, Free Software Fundation, Inc."; procedure Cat (File : String); -- Print the contents of file on standard output. diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 2f66975..015c92e 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -519,8 +519,8 @@ package body Lib.Load is -- legitimately occurs (e.g. two package bodies that contain -- inlined subprogram referenced by the other). - -- We also ignore limited_with clauses, because their purpose is - -- precisely to create legal circular structures. + -- Ada0Y (AI-50217): We also ignore limited_with clauses, because + -- their purpose is precisely to create legal circular structures. if Loading (Unum) and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index ea5ec34..fcb5f19 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -214,7 +214,8 @@ package body Lib.Writ is Item := First (Context_Items (Cunit)); while Present (Item) loop - -- limited_with_clauses do not create dependencies. + -- Ada0Y (AI-50217): limited with_clauses do not create + -- dependencies if Nkind (Item) = N_With_Clause and then not (Limited_Present (Item)) diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index f71ae7b..c1c45c5 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -1313,6 +1313,7 @@ package body MLib.Prj is Interfaces => Arguments (1 .. Argument_Number), Lib_Filename => Lib_Filename.all, Lib_Dir => Lib_Dirpath.all, + Symbol_Data => Data.Symbol_Data, Driver_Name => Driver_Name, Lib_Address => DLL_Address.all, Lib_Version => Lib_Version.all, diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index 0fc5919..d8e280a 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -79,6 +79,7 @@ package body MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -92,6 +93,7 @@ package body MLib.Tgt is pragma Unreferenced (Interfaces); pragma Unreferenced (Lib_Filename); pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); pragma Unreferenced (Driver_Name); pragma Unreferenced (Lib_Address); pragma Unreferenced (Lib_Version); diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads index d7cad10b..1fac4efe3 100644 --- a/gcc/ada/mlib-tgt.ads +++ b/gcc/ada/mlib-tgt.ads @@ -113,6 +113,7 @@ package MLib.Tgt is Interfaces : Argument_List; Lib_Filename : String; Lib_Dir : String; + Symbol_Data : Symbol_Record; Driver_Name : Name_Id := No_Name; Lib_Address : String := ""; Lib_Version : String := ""; @@ -125,23 +126,33 @@ package MLib.Tgt is -- Afiles is the list of ALI files for the Ada object files. -- Options is a list of options to be passed to the tool (gcc or other) -- that effectively builds the dynamic library. + -- -- Interfaces is the list of ALI files for the interfaces of a SAL. -- It is empty if the library is not a SAL. + -- -- Lib_Filename is the name of the library, without any prefix or -- extension. For example, on Unix, if Lib_Filename is "toto", the name of -- the library file will be "libtoto.so". + -- -- Lib_Dir is the directory path where the library will be located. + -- -- Lib_Address is the base address of the library for a non relocatable -- library, given as an hexadecimal string. - -- For OSes that support symbolic links, Lib_Version, if non null, is - -- the actual file name of the library. For example on Unix, - -- if Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1", - -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which will - -- be the actual library file. + -- + -- For OSes that support symbolic links, Lib_Version, if non null, + -- is the actual file name of the library. For example on Unix, if + -- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1", + -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which + -- will be the actual library file. + -- -- Relocatable indicates if the library should be relocatable or not, -- for those OSes that actually support non relocatable dynamic libraries. -- Relocatable indicates that automatic elaboration/finalization must be -- indicated to the linker, if possible. + -- + -- Symbol_Data is used for some patforms, including VMS, to generate + -- the symbols to be exported by the library. + -- -- Note: Depending on the OS, some of the parameters may not be taken -- into account. For example, on Linux, Foreign, Afiles Lib_Address and -- Relocatable are ignored. diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 86d47b3..8066aa7 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -782,7 +782,7 @@ package body Ch10 is -- Processing for WITH clause - -- First check for LIMITED WITH + -- Ada0Y (AI-50217): First check for LIMITED WITH if Token = Tok_Limited then Has_Limited := True; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index b88c494..f560c8d 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1127,6 +1127,9 @@ package body Ch4 is -- Error recovery: can raise Error_Resync + -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support + -- to Ada0Y limited aggregates (AI-287) + function P_Aggregate_Or_Paren_Expr return Node_Id is Aggregate_Node : Node_Id; Expr_List : List_Id; @@ -1373,6 +1376,10 @@ package body Ch4 is -- Error recovery: can raise Error_Resync + -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION + -- rules have been extended to give support to Ada0Y limited + -- aggregates (AI-287) + function P_Record_Or_Array_Component_Association return Node_Id is Assoc_Node : Node_Id; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index e3fb2c0..8482fd2 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -69,6 +69,9 @@ package body Prj.Attr is "LVlibrary_options#" & "SVlibrary_src_dir#" & "SVlibrary_gcc#" & + "SVlibrary_symbol_file#" & + "SVlibrary_symbol_policy#" & + "SVlibrary_reference_symbol_file#" & "LVmain#" & "LVlanguages#" & "SVmain_language#" & diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index cda03ee..6089bea 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1350,16 +1350,32 @@ package body Prj.Nmsc is (Snames.Name_Library_Src_Dir, Data.Decl.Attributes); - Auto_Init_Supported - : constant Boolean := - MLib.Tgt. - Standalone_Library_Auto_Init_Is_Supported; + Lib_Symbol_File : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Symbol_File, + Data.Decl.Attributes); + + Lib_Symbol_Policy : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Symbol_Policy, + Data.Decl.Attributes); + + Lib_Ref_Symbol_File : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Reference_Symbol_File, + Data.Decl.Attributes); + + Auto_Init_Supported : constant Boolean := + MLib.Tgt. + Standalone_Library_Auto_Init_Is_Supported; + + OK : Boolean := True; begin pragma Assert (Lib_Interfaces.Kind = List); - -- It is a library project file if attribute Library_Interface - -- is defined. + -- It is a stand-alone library project file if attribute + -- Library_Interface is defined. if not Lib_Interfaces.Default then declare @@ -1566,102 +1582,257 @@ package body Prj.Nmsc is Lib_Auto_Init.Location); end if; end if; + end; - if Lib_Src_Dir.Value /= Empty_String then - declare - Dir_Id : constant Name_Id := Lib_Src_Dir.Value; + -- If attribute Library_Src_Dir is defined and not the + -- empty string, check if the directory exist and is not + -- the object directory or one of the source directories. + -- This is the directory where copies of the interface + -- sources will be copied. Note that this directory may be + -- the library directory. - begin - Locate_Directory - (Dir_Id, Data.Display_Directory, - Data.Library_Src_Dir, - Data.Display_Library_Src_Dir); + if Lib_Src_Dir.Value /= Empty_String then + declare + Dir_Id : constant Name_Id := Lib_Src_Dir.Value; - -- Comment needed here ??? + begin + Locate_Directory + (Dir_Id, Data.Display_Directory, + Data.Library_Src_Dir, + Data.Display_Library_Src_Dir); - if Data.Library_Src_Dir = No_Name then + -- If directory does not exist, report an error - -- Get the absolute name of the library directory - -- that does not exist, to report an error. + if Data.Library_Src_Dir = No_Name then - declare - Dir_Name : constant String := - Get_Name_String (Dir_Id); - begin - if Is_Absolute_Path (Dir_Name) then - Err_Vars.Error_Msg_Name_1 := Dir_Id; + -- Get the absolute name of the library directory + -- that does not exist, to report an error. - else - Get_Name_String (Data.Directory); + declare + Dir_Name : constant String := + Get_Name_String (Dir_Id); - if Name_Buffer (Name_Len) /= - Directory_Separator - then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := - Directory_Separator; - end if; + begin + if Is_Absolute_Path (Dir_Name) then + Err_Vars.Error_Msg_Name_1 := Dir_Id; - Name_Buffer - (Name_Len + 1 .. - Name_Len + Dir_Name'Length) := - Dir_Name; - Name_Len := Name_Len + Dir_Name'Length; - Err_Vars.Error_Msg_Name_1 := Name_Find; - end if; + else + Get_Name_String (Data.Directory); - -- Report the error + if Name_Buffer (Name_Len) /= + Directory_Separator + then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := + Directory_Separator; + end if; - Error_Msg - (Project, - "Directory { does not exist", - Lib_Src_Dir.Location); - end; + Name_Buffer + (Name_Len + 1 .. + Name_Len + Dir_Name'Length) := + Dir_Name; + Name_Len := Name_Len + Dir_Name'Length; + Err_Vars.Error_Msg_Name_1 := Name_Find; + end if; - -- And comment needed here ??? + -- Report the error - elsif Data.Library_Src_Dir = Data.Object_Directory then Error_Msg (Project, - "directory to copy interfaces cannot be " & - "the object directory", + "Directory { does not exist", Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Name; + end; - -- And comment needed here ??? + -- Report an error if it is the same as the object + -- directory. - else - declare - Src_Dirs : String_List_Id := Data.Source_Dirs; - Src_Dir : String_Element; - begin - while Src_Dirs /= Nil_String loop - Src_Dir := String_Elements.Table (Src_Dirs); - Src_Dirs := Src_Dir.Next; - - if Data.Library_Src_Dir = Src_Dir.Value then - Error_Msg - (Project, - "directory to copy interfaces cannot " & - "be one of the source directories", - Lib_Src_Dir.Location); - Data.Library_Src_Dir := No_Name; - exit; - end if; - end loop; - end; + elsif Data.Library_Src_Dir = Data.Object_Directory then + Error_Msg + (Project, + "directory to copy interfaces cannot be " & + "the object directory", + Lib_Src_Dir.Location); + Data.Library_Src_Dir := No_Name; - if Data.Library_Src_Dir /= No_Name - and then Current_Verbosity = High + -- Check if it is the same as one of the source + -- directories. + + else + declare + Src_Dirs : String_List_Id := Data.Source_Dirs; + Src_Dir : String_Element; + + begin + while Src_Dirs /= Nil_String loop + Src_Dir := String_Elements.Table (Src_Dirs); + Src_Dirs := Src_Dir.Next; + + -- Report an error if it is one of the + -- source directories. + + if Data.Library_Src_Dir = Src_Dir.Value then + Error_Msg + (Project, + "directory to copy interfaces cannot " & + "be one of the source directories", + Lib_Src_Dir.Location); + Data.Library_Src_Dir := No_Name; + exit; + end if; + end loop; + end; + + if Data.Library_Src_Dir /= No_Name + and then Current_Verbosity = High + then + Write_Str ("Directory to copy interfaces ="""); + Write_Str (Get_Name_String (Data.Library_Dir)); + Write_Line (""""); + end if; + end if; + end; + end if; + + if not Lib_Symbol_File.Default then + Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value; + + Get_Name_String (Lib_Symbol_File.Value); + + if Name_Len = 0 then + Error_Msg + (Project, + "symbol file name cannot be an empty string", + Lib_Symbol_File.Location); + + else + OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); + + if OK then + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' + or else Name_Buffer (J) = Directory_Separator then - Write_Str ("Directory to copy interfaces ="""); - Write_Str (Get_Name_String (Data.Library_Dir)); - Write_Line (""""); + OK := False; + exit; end if; - end if; - end; + end loop; + end if; + + if not OK then + Error_Msg_Name_1 := Lib_Symbol_File.Value; + Error_Msg + (Project, + "symbol file name { is illegal. " & + "Name canot include directory info.", + Lib_Symbol_File.Location); + end if; end if; - end; + end if; + + if not Lib_Symbol_Policy.Default then + declare + Value : constant String := + To_Lower + (Get_Name_String (Lib_Symbol_Policy.Value)); + + begin + if Value = "autonomous" or else Value = "default" then + Data.Symbol_Data.Symbol_Policy := Autonomous; + + elsif Value = "compliant" then + Data.Symbol_Data.Symbol_Policy := Compliant; + + elsif Value = "controlled" then + Data.Symbol_Data.Symbol_Policy := Controlled; + + else + Error_Msg + (Project, + "illegal value for Library_Symbol_Policy", + Lib_Symbol_Policy.Location); + end if; + end; + end if; + + if Lib_Ref_Symbol_File.Default then + if Data.Symbol_Data.Symbol_Policy /= Autonomous then + Error_Msg + (Project, + "a reference symbol file need to be defined", + Lib_Symbol_Policy.Location); + end if; + + else + Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value; + + Get_Name_String (Lib_Symbol_File.Value); + + if Name_Len = 0 then + Error_Msg + (Project, + "reference symbol file name cannot be an empty string", + Lib_Symbol_File.Location); + + else + OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); + + if OK then + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' + or else Name_Buffer (J) = Directory_Separator + then + OK := False; + exit; + end if; + end loop; + end if; + + if not OK then + Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; + Error_Msg + (Project, + "reference symbol file { name is illegal. " & + "Name canot include directory info.", + Lib_Ref_Symbol_File.Location); + end if; + + if not Is_Regular_File + (Get_Name_String (Data.Object_Directory) & + Directory_Separator & + Get_Name_String (Lib_Ref_Symbol_File.Value)) + then + Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; + Error_Msg + (Project, + "library reference symbol file { does not exist", + Lib_Ref_Symbol_File.Location); + end if; + + if Data.Symbol_Data.Symbol_File /= No_Name then + declare + Symbol : String := + Get_Name_String + (Data.Symbol_Data.Symbol_File); + + Reference : String := + Get_Name_String + (Data.Symbol_Data.Reference); + + begin + Canonical_Case_File_Name (Symbol); + Canonical_Case_File_Name (Reference); + + if Symbol = Reference then + Error_Msg + (Project, + "reference symbol file and symbol file " & + "cannot be the same file", + Lib_Ref_Symbol_File.Location); + end if; + end; + end if; + end if; + end if; end if; end Standalone_Library; end if; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 730af24..fc817ea 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -96,6 +96,7 @@ package body Prj is Standalone_Library => False, Lib_Interface_ALIs => Nil_String, Lib_Auto_Init => False, + Symbol_Data => No_Symbols, Sources_Present => True, Sources => Nil_String, Source_Dirs => Nil_String, diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 270cb4e..b323a86 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -75,6 +75,21 @@ package Prj is type Lib_Kind is (Static, Dynamic, Relocatable); + type Policy is (Autonomous, Compliant, Controlled); + -- See explaination about this type in package Symbol + + type Symbol_Record is record + Symbol_File : Name_Id := No_Name; + Reference : Name_Id := No_Name; + Symbol_Policy : Policy := Autonomous; + end record; + -- Type to keep the symbol data to be used when building a shared library + + No_Symbols : Symbol_Record := + (Symbol_File => No_Name, + Reference => No_Name, + Symbol_Policy => Autonomous); + function Empty_String return Name_Id; type Project_Id is new Nat; @@ -418,6 +433,9 @@ package Prj is -- For non static Standalone Library Project Files, indicate if -- the library initialisation should be automatic. + Symbol_Data : Symbol_Record := No_Symbols; + -- Symbol file name, reference symbol file name, symbol policy + Sources_Present : Boolean := True; -- A flag that indicates if there are sources in this project file. -- There are no sources if 1) Source_Dirs is specified as an diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 5759855..4999e0b 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -258,6 +258,8 @@ package body Rtsfind is for J in RE_Id loop RE_Table (J) := Empty; end loop; + + RTE_Is_Available := False; end Initialize; ------------ diff --git a/gcc/ada/s-thread.adb b/gcc/ada/s-thread.adb index 6687d28..369d46d 100644 --- a/gcc/ada/s-thread.adb +++ b/gcc/ada/s-thread.adb @@ -31,14 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the VxWorks version of this package - -pragma Restrictions (No_Tasking); --- The VxWorks version of this package is intended only for programs --- which do not use Ada tasking. This restriction ensures that this --- will be checked by the binder. - -with System.Secondary_Stack; +-- This is a dummy version of this package. with Unchecked_Conversion; @@ -46,29 +39,13 @@ with System.Threads.Initialization; package body System.Threads is - package SSS renames System.Secondary_Stack; - - Current_ATSD : aliased System.Address := System.Null_Address; - pragma Export (C, Current_ATSD, "__gnat_current_atsd"); - - function From_Address is - new Unchecked_Conversion (Address, ATSD_Access); - - procedure Init_Float; - pragma Import (C, Init_Float, "__gnat_init_float"); - - procedure Install_Handler; - pragma Import (C, Install_Handler, "__gnat_install_handler"); - ----------------------- -- Get_Current_Excep -- ----------------------- function Get_Current_Excep return EOA is - CTSD : ATSD_Access := From_Address (Current_ATSD); begin - pragma Assert (Current_ATSD /= System.Null_Address); - return CTSD.Current_Excep'Access; + return null; end Get_Current_Excep; ------------------------ @@ -76,10 +53,8 @@ package body System.Threads is ------------------------ function Get_Jmpbuf_Address return Address is - CTSD : ATSD_Access := From_Address (Current_ATSD); begin - pragma Assert (Current_ATSD /= System.Null_Address); - return CTSD.Jmpbuf_Address; + return Null_Address; end Get_Jmpbuf_Address; ------------------------ @@ -87,10 +62,8 @@ package body System.Threads is ------------------------ function Get_Sec_Stack_Addr return Address is - CTSD : ATSD_Access := From_Address (Current_ATSD); begin - pragma Assert (Current_ATSD /= System.Null_Address); - return CTSD.Sec_Stack_Addr; + return Null_Address; end Get_Sec_Stack_Addr; ------------------------ @@ -98,10 +71,9 @@ package body System.Threads is ------------------------ procedure Set_Jmpbuf_Address (Addr : Address) is - CTSD : ATSD_Access := From_Address (Current_ATSD); + pragma Unreferenced (Addr); begin - pragma Assert (Current_ATSD /= System.Null_Address); - CTSD.Jmpbuf_Address := Addr; + null; end Set_Jmpbuf_Address; ------------------------ @@ -109,10 +81,9 @@ package body System.Threads is ------------------------ procedure Set_Sec_Stack_Addr (Addr : Address) is - CTSD : ATSD_Access := From_Address (Current_ATSD); + pragma Unreferenced (Addr); begin - pragma Assert (Current_ATSD /= System.Null_Address); - CTSD.Sec_Stack_Addr := Addr; + null; end Set_Sec_Stack_Addr; ----------------------- @@ -124,18 +95,11 @@ package body System.Threads is Sec_Stack_Size : Natural; Process_ATSD_Address : System.Address) is - -- Current_ATSD must already be a taskVar of taskIdSelf. - -- No assertion because taskVarGet is not available on VxWorks/CERT - - TSD : ATSD_Access := From_Address (Process_ATSD_Address); - + pragma Unreferenced (Sec_Stack_Address); + pragma Unreferenced (Sec_Stack_Size); + pragma Unreferenced (Process_ATSD_Address); begin - TSD.Sec_Stack_Addr := Sec_Stack_Address; - SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size); - Current_ATSD := Process_ATSD_Address; - - Install_Handler; - Init_Float; + null; end Thread_Body_Enter; ---------------------------------- @@ -147,8 +111,6 @@ package body System.Threads is is pragma Unreferenced (EO); begin - -- No action for this target - null; end Thread_Body_Exceptional_Exit; @@ -158,11 +120,7 @@ package body System.Threads is procedure Thread_Body_Leave is begin - -- No action for this target - null; end Thread_Body_Leave; -begin - System.Threads.Initialization.Init_RTS; end System.Threads; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index b729324..cb9c2a3 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -866,6 +866,8 @@ package body Sem_Aggr is Error_Msg_N ("aggregate type cannot have limited component", N); Explain_Limited_Type (Typ, N); + -- Ada0Y (AI-287): Limited aggregates allowed + elsif Is_Limited_Type (Typ) and not Extensions_Allowed then @@ -1915,12 +1917,17 @@ package body Sem_Aggr is Error_Msg_N ("type of extension aggregate must be tagged", N); return; - elsif Is_Limited_Type (Typ) - and not Extensions_Allowed - then - Error_Msg_N ("aggregate type cannot be limited", N); - Explain_Limited_Type (Typ, N); - return; + elsif Is_Limited_Type (Typ) then + + -- Ada0Y (AI-287): Limited aggregates are allowed + + if Extensions_Allowed then + null; + else + Error_Msg_N ("aggregate type cannot be limited", N); + Explain_Limited_Type (Typ, N); + return; + end if; elsif Is_Class_Wide_Type (Typ) then Error_Msg_N ("aggregate cannot be of a class-wide type", N); @@ -2023,12 +2030,12 @@ package body Sem_Aggr is Mbox_Present : Boolean := False; Others_Mbox : Boolean := False; - -- Variables used in case of default initialization to provide a - -- functionality similar to Others_Etype. Mbox_Present indicates - -- that the component takes its default initialization; Others_Mbox - -- indicates that at least one component takes its default initiali- - -- zation. Similar to Others_Etype, they are also updated as a side - -- effect of function Get_Value. + -- Ada0Y (AI-287): Variables used in case of default initialization to + -- provide a functionality similar to Others_Etype. Mbox_Present + -- indicates that the component takes its default initialization; + -- Others_Mbox indicates that at least one component takes its default + -- initialization. Similar to Others_Etype, they are also updated as a + -- side effect of function Get_Value. procedure Add_Association (Component : Entity_Id; @@ -2212,6 +2219,7 @@ package body Sem_Aggr is and then Comes_From_Source (Compon) and then not In_Instance_Body then + -- Ada0Y (AI-287): Limited aggregates are allowed if Extensions_Allowed and then Present (Expression (Assoc)) @@ -2251,6 +2259,10 @@ package body Sem_Aggr is -- indispensable otherwise, because each one must be -- expanded individually to preserve side-effects. + -- Ada0Y (AI-287): In case of default initialization of + -- components, we duplicate the corresponding default + -- expression (from the record type declaration). + if Box_Present (Assoc) then Others_Mbox := True; Mbox_Present := True; @@ -2845,9 +2857,10 @@ package body Sem_Aggr is if Mbox_Present and then Is_Limited_Type (Etype (Component)) then - -- In case of default initialization of a limited component we - -- pass the limited component to the expander. The expander will - -- generate calls to the corresponding initialization subprograms. + -- Ada0Y (AI-287): In case of default initialization of a limited + -- component we pass the limited component to the expander. The + -- expander will generate calls to the corresponding initiali- + -- zation subprograms. Add_Association (Component => Component, @@ -2884,6 +2897,9 @@ package body Sem_Aggr is Typech := Empty; if Nkind (Selectr) = N_Others_Choice then + + -- Ada0Y (AI-287): others choice may have expression or mbox + if No (Others_Etype) and then not Others_Mbox then diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index efefdb8..400b162 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2184,9 +2184,12 @@ package body Sem_Attr is if Is_Entity_Name (P) and then Is_Type (Entity (P)) then -- If we are within an instance, the attribute must be legal - -- because it was valid in the generic unit. + -- because it was valid in the generic unit. Ditto if this is + -- an inlining of a function declared in an instance. - if In_Instance then + if In_Instance + or else In_Inlined_Body + then return; -- For sure OK if we have a real private type itself, but must diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index bb33f4c..3dac1e3 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -761,7 +761,7 @@ package body Sem_Cat is return; end if; - -- Process explicit with_clauses that are not limited. + -- Ada0Y (AI-50217): Process explicit with_clauses that are not limited declare Item : Node_Id; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 323afa4..4fdf9a9 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -77,6 +77,7 @@ package body Sem_Ch10 is -- in a limited_with clause. If the package was not previously analyzed -- then it also performs a basic decoration of the real entities; this -- is required to do not pass non-decorated entities to the back-end. + -- Implements Ada0Y (AI-50217). procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); -- Check whether the source for the body of a compilation unit must @@ -95,11 +96,12 @@ package body Sem_Ch10 is -- and not in an inner frame. procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id); - -- if a child unit appears in a limited_with clause, there are implicit + -- If a child unit appears in a limited_with clause, there are implicit -- limited_with clauses on all parents that are not already visible -- through a regular with clause. This procedure creates the implicit -- limited with_clauses for the parents and loads the corresponding units. -- The shadow entities are created when the inserted clause is analyzed. + -- Implements Ada0Y (AI-50217). procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id); -- When a child unit appears in a context clause, the implicit withs on @@ -127,11 +129,11 @@ package body Sem_Ch10 is procedure Install_Limited_Context_Clauses (N : Node_Id); -- Subsidiary to Install_Context. Process only limited with_clauses - -- for current unit. + -- for current unit. Implements Ada0Y (AI-50217). procedure Install_Limited_Withed_Unit (N : Node_Id); -- Place shadow entities for a limited_with package in the visibility - -- structures for the current compilation. + -- structures for the current compilation. Implements Ada0Y (AI-50217). procedure Install_Withed_Unit (With_Clause : Node_Id); -- If the unit is not a child unit, make unit immediately visible. @@ -174,7 +176,7 @@ package body Sem_Ch10 is procedure Remove_Limited_With_Clause (N : Node_Id); -- Remove from visibility the shadow entities introduced for a package - -- mentioned in a limited_with clause. + -- mentioned in a limited_with clause. Implements Ada0Y (AI-50217). procedure Remove_Parents (Lib_Unit : Node_Id); -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent @@ -611,6 +613,9 @@ package body Sem_Ch10 is begin Item := First (Context_Items (N)); while Present (Item) loop + + -- Ada0Y (AI-50217): Do not consider limited-withed units + if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) and then not Limited_Present (Item) @@ -788,8 +793,8 @@ package body Sem_Ch10 is -- Loop through context items. This is done is three passes: -- a) The first pass analyze non-limited with-clauses. -- b) The second pass add implicit limited_with clauses for - -- the parents of child units. - -- c) The third pass analyzes limited_with clauses. + -- the parents of child units (Ada0Y: AI-50217) + -- c) The third pass analyzes limited_with clauses (Ada0Y: AI-50217) Item := First (Context_Items (N)); while Present (Item) loop @@ -1590,8 +1595,8 @@ package body Sem_Ch10 is begin if Limited_Present (N) then - - -- Build visibility structures but do not analyze unit + -- Ada0Y (AI-50217): Build visibility structures but do not + -- analyze unit Build_Limited_Views (N); return; @@ -4006,8 +4011,9 @@ package body Sem_Ch10 is Unit_Name : Entity_Id; begin - -- We remove the context clauses in two phases: limited-views first - -- and regular-views later (to maintain the stack model). + -- Ada0Y (AI-50217): We remove the context clauses in two phases: + -- limited-views first and regular-views later (to maintain the + -- stack model). -- First Phase: Remove limited_with context clauses diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index babcc70..c84006d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -987,6 +987,7 @@ package body Sem_Ch12 is Defining_Identifier (Analyzed_Formal)); if No (Match) then + Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_NE ("missing actual&", Instantiation_Node, Defining_Identifier (Formal)); @@ -1075,6 +1076,7 @@ package body Sem_Ch12 is Defining_Identifier (Original_Node (Analyzed_Formal))); if No (Match) then + Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_NE ("missing actual&", Instantiation_Node, Defining_Identifier (Formal)); @@ -1111,6 +1113,8 @@ package body Sem_Ch12 is end loop; if Num_Actuals > Num_Matched then + Error_Msg_Sloc := Sloc (Gen_Unit); + if Present (Selector_Name (Actual)) then Error_Msg_NE ("unmatched actual&", @@ -2348,6 +2352,8 @@ package body Sem_Ch12 is elsif Ekind (Gen_Unit) /= E_Generic_Package then + -- Ada0Y (AI-50217): Instance can not be used in limited with_clause + if From_With_Type (Gen_Unit) then Error_Msg_N ("cannot instantiate a limited withed package", Gen_Id); @@ -6620,6 +6626,7 @@ package body Sem_Ch12 is end if; else + Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); Error_Msg_NE ("missing actual&", Instantiation_Node, Formal_Sub); Error_Msg_NE @@ -6746,6 +6753,9 @@ package body Sem_Ch12 is Subt_Decl : Node_Id := Empty; begin + -- Sloc for error message on missing actual. + Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal))); + if Get_Instance_Of (Formal_Id) /= Formal_Id then Error_Msg_N ("duplicate instantiation of generic parameter", Actual); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 38c7580..afdb50f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -690,6 +690,10 @@ package body Sem_Ch3 is -- if the designated type is. Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); + + -- Ada0Y (AI-50217): Propagate the attribute that indicates that the + -- designated type comes from the limited view (for back-end purposes). + Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type)); -- The context is either a subprogram declaration or an access @@ -857,9 +861,9 @@ package body Sem_Ch3 is -- access type is also imported, and therefore restricted in its use. -- The access type may already be imported, so keep setting otherwise. - -- If the non-limited view of the designated type is available, use - -- it as the designated type of the access type, so that the back-end - -- gets a usable entity. + -- Ada0Y (AI-50217): If the non-limited view of the designated type is + -- available, use it as the designated type of the access type, so that + -- the back-end gets a usable entity. if From_With_Type (Desig) then Set_From_With_Type (T); @@ -2448,9 +2452,11 @@ package body Sem_Ch3 is begin Prev := Find_Type_Name (N); - -- The full view, if present, now points to the current type. If the - -- type was previously decorated when imported through a LIMITED WITH - -- clause, it appears as incomplete but has no full view. + -- The full view, if present, now points to the current type + + -- Ada0Y (AI-50217): If the type was previously decorated when imported + -- through a LIMITED WITH clause, it appears as incomplete but has no + -- full view. if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) @@ -6234,8 +6240,8 @@ package body Sem_Ch3 is or else Is_Limited_Composite (T)) and then not In_Instance then - -- Relax the strictness of the front-end in case of limited - -- aggregates and extension aggregates. + -- Ada0Y (AI-287): Relax the strictness of the front-end in case of + -- limited aggregates and extension aggregates. if Extensions_Allowed and then (Nkind (Exp) = N_Aggregate diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 798a80c..e122af7 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -342,6 +342,10 @@ package body Sem_Ch4 is and then Comes_From_Source (N) and then not In_Instance_Body then + -- Ada0Y (AI-287): Do not post an error if the expression corres- + -- ponds to a limited aggregate. Limited aggregates are checked in + -- sem_aggr in a per-component manner (cf. Get_Value subprogram). + if Extensions_Allowed and then Nkind (Expression (E)) = N_Aggregate then @@ -3442,6 +3446,9 @@ package body Sem_Ch4 is Actual := First_Actual (N); while Present (Actual) loop + -- Ada0Y (AI-50217): Post an error in case of premature usage of + -- an entity from the limited view. + if not Analyzed (Etype (Actual)) and then From_With_Type (Etype (Actual)) then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05c0ccf..d28109b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4840,9 +4840,9 @@ package body Sem_Ch6 is and then Ekind (Root_Type (Formal_Type)) = E_Incomplete_Type) then - - -- Incomplete tagged types that are made visible through - -- a limited with_clause are valid formal types. + -- Ada0Y (AI-50217): Incomplete tagged types that are made + -- visible through a limited with_clause are valid formal + -- types. if From_With_Type (Formal_Type) and then Is_Tagged_Type (Formal_Type) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5240193..6c65a7b 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -792,6 +792,8 @@ package body Sem_Ch8 is Error_Msg_N ("expect package name in renaming", Name (N)); + -- Ada0Y (AI-50217): Limited withed packages can not be renamed + elsif Ekind (Old_P) = E_Package and then From_With_Type (Old_P) then @@ -3389,6 +3391,8 @@ package body Sem_Ch8 is Set_Chars (Selector, Chars (Id)); end if; + -- Ada0Y (AI-50217): Check usage of entities in limited withed units + if Ekind (P_Name) = E_Package and then From_With_Type (P_Name) then @@ -5294,6 +5298,8 @@ package body Sem_Ch8 is Set_In_Use (P); + -- Ada0Y (AI-50217): Check restriction. + if From_With_Type (P) then Error_Msg_N ("limited withed package cannot appear in use clause", N); end if; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index dda7d1d7..57bbb3de 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -824,6 +824,9 @@ package body Sem_Type is then return True; + -- Ada0Y (AI-50217): Additional branches to make the shadow entity + -- compatible with its real entity. + elsif From_With_Type (T1) then -- If the expected type is the non-limited view of a type, the diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index dc67b50..4455039 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -818,8 +818,8 @@ package body Sem_Util is begin if Ekind (T) = E_Incomplete_Type then - -- If the type is available through a limited_with_clause, - -- verify that its full view has been analyzed. + -- Ada0Y (AI-50217): If the type is available through a limited + -- with_clause, verify that its full view has been analyzed. if From_With_Type (T) and then Present (Non_Limited_View (T)) diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index acadd64..8691ab6 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3015,7 +3015,8 @@ package Sinfo is -- separable by the parser. The choices list may represent either a -- list of selector names in the record aggregate case, or a list of -- discrete choices in the array aggregate case or an N_Others_Choice - -- node (which appears as a singleton list). + -- node (which appears as a singleton list). Box_Present gives support + -- to Ada0Y (AI-287). ------------------------------------ -- 4.3.1 Commponent Choice List -- @@ -5090,6 +5091,9 @@ package Sinfo is -- Unreferenced_In_Spec (Flag7-Sem) -- No_Entities_Ref_In_Spec (Flag8-Sem) + -- Note: Limited_Present and Limited_View_Installed give support to + -- Ada0Y (AI-50217). + ---------------------- -- With_Type clause -- ---------------------- diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 829c1a6..85294fe 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -618,8 +618,10 @@ package body Snames is "library_kind#" & "library_name#" & "library_options#" & + "library_reference_symbol_file#" & "library_src_dir#" & "library_symbol_file#" & + "library_symbol_policy#" & "library_version#" & "linker#" & "local_configuration_pragmas#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index b6517df..df33ca0 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -902,33 +902,35 @@ package Snames is Name_Library_Kind : constant Name_Id := N + 558; Name_Library_Name : constant Name_Id := N + 559; Name_Library_Options : constant Name_Id := N + 560; - Name_Library_Src_Dir : constant Name_Id := N + 561; - Name_Library_Symbol_File : constant Name_Id := N + 562; - Name_Library_Version : constant Name_Id := N + 563; - Name_Linker : constant Name_Id := N + 564; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 565; - Name_Locally_Removed_Files : constant Name_Id := N + 566; - Name_Naming : constant Name_Id := N + 567; - Name_Object_Dir : constant Name_Id := N + 568; - Name_Pretty_Printer : constant Name_Id := N + 569; - Name_Project : constant Name_Id := N + 570; - Name_Separate_Suffix : constant Name_Id := N + 571; - Name_Source_Dirs : constant Name_Id := N + 572; - Name_Source_Files : constant Name_Id := N + 573; - Name_Source_List_File : constant Name_Id := N + 574; - Name_Spec : constant Name_Id := N + 575; - Name_Spec_Suffix : constant Name_Id := N + 576; - Name_Specification : constant Name_Id := N + 577; - Name_Specification_Exceptions : constant Name_Id := N + 578; - Name_Specification_Suffix : constant Name_Id := N + 579; - Name_Switches : constant Name_Id := N + 580; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 561; + Name_Library_Src_Dir : constant Name_Id := N + 562; + Name_Library_Symbol_File : constant Name_Id := N + 563; + Name_Library_Symbol_Policy : constant Name_Id := N + 564; + Name_Library_Version : constant Name_Id := N + 565; + Name_Linker : constant Name_Id := N + 566; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 567; + Name_Locally_Removed_Files : constant Name_Id := N + 568; + Name_Naming : constant Name_Id := N + 569; + Name_Object_Dir : constant Name_Id := N + 570; + Name_Pretty_Printer : constant Name_Id := N + 571; + Name_Project : constant Name_Id := N + 572; + Name_Separate_Suffix : constant Name_Id := N + 573; + Name_Source_Dirs : constant Name_Id := N + 574; + Name_Source_Files : constant Name_Id := N + 575; + Name_Source_List_File : constant Name_Id := N + 576; + Name_Spec : constant Name_Id := N + 577; + Name_Spec_Suffix : constant Name_Id := N + 578; + Name_Specification : constant Name_Id := N + 579; + Name_Specification_Exceptions : constant Name_Id := N + 580; + Name_Specification_Suffix : constant Name_Id := N + 581; + Name_Switches : constant Name_Id := N + 582; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 581; + Name_Unaligned_Valid : constant Name_Id := N + 583; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 581; + Last_Predefined_Name : constant Name_Id := N + 583; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 277ede3..c0ac7bc 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -929,6 +929,8 @@ package body Sprint is Sprint_Bar_List (Choices (Node)); Write_Str (" => "); + -- Ada0Y (AI-287): Print the mbox if present + if Box_Present (Node) then Write_Str_With_Col_Check ("<>"); else @@ -2495,6 +2497,9 @@ package body Sprint is else if First_Name (Node) or else not Dump_Original_Only then + + -- Ada0Y (AI-50217): Print limited with_clauses + if Limited_Present (Node) then Write_Indent_Str ("limited with "); else @@ -2513,7 +2518,6 @@ package body Sprint is end if; when N_With_Type_Clause => - Write_Indent_Str ("with type "); Sprint_Node_Sloc (Name (Node)); diff --git a/gcc/ada/symbols.adb b/gcc/ada/symbols.adb index 2c3e7d0..0ccd4cb 100644 --- a/gcc/ada/symbols.adb +++ b/gcc/ada/symbols.adb @@ -36,14 +36,18 @@ package body Symbols is ---------------- procedure Initialize - (Symbol_File : String; - Force : Boolean; - Quiet : Boolean; - Success : out Boolean) + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) is pragma Unreferenced (Symbol_File); - pragma Unreferenced (Force); + pragma Unreferenced (Reference); + pragma Unreferenced (Symbol_Policy); pragma Unreferenced (Quiet); + pragma Unreferenced (Version); begin Put_Line ("creation of symbol files are not supported on this platform"); diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads index 9e823ef..73fa2c8 100644 --- a/gcc/ada/symbols.ads +++ b/gcc/ada/symbols.ads @@ -33,6 +33,20 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; package Symbols is + type Policy is + -- Symbol policy: + + (Autonomous, + -- Create a symbol file without considering any reference + + Compliant, + -- Either create a symbol file with the same major and minor IDs if + -- all symbols are already found in the reference file or with an + -- incremented minor ID, if not. + + Controlled); + -- Fail if symbols are not the same as those in the reference file + type Symbol_Kind is (Data, Proc); -- To distinguish between the different kinds of symbols @@ -52,16 +66,18 @@ package Symbols is -- The symbol tables Original_Symbols : Symbol_Table.Instance; - -- The symbols, if any, found in the original symbol table + -- The symbols, if any, found in the reference symbol table Complete_Symbols : Symbol_Table.Instance; -- The symbols, if any, found in the objects files procedure Initialize - (Symbol_File : String; - Force : Boolean; - Quiet : Boolean; - Success : out Boolean); + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean); -- Initialize a symbol file. This procedure must be called before -- Processing any object file. Depending on the platforms and the -- circumstances, additional messages may be issued if Quiet is False. diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 76b1c3e..c729f48 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -235,7 +235,7 @@ begin -- Line for -gnatN switch Write_Switch_Char ("N"); - Write_Line ("Full (frontend) inlining of subprograqms"); + Write_Line ("Full (frontend) inlining of subprograms"); -- Line for -gnato switch diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 713a91b..cca4285 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2003 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -359,10 +359,7 @@ package body Xref_Lib is -- Default_Project_File -- -------------------------- - function Default_Project_File - (Dir_Name : String) - return String - is + function Default_Project_File (Dir_Name : String) return String is My_Dir : Dir_Type; Dir_Ent : File_Name_String; Last : Natural; @@ -396,8 +393,7 @@ package body Xref_Lib is function File_Name (File : ALI_File; - Num : Positive) - return File_Reference + Num : Positive) return File_Reference is begin return File.Dep.Table (Num); @@ -876,6 +872,9 @@ package body Xref_Lib is -- unit number is optional. It is specified only if the parent type -- is not defined in the current unit. + -- We also have the format for generic instantiations, as in + -- 7a5*Uid(3|5I8[4|2]) 2|4r74 + -- We could also have something like -- 16I9*I<integer> -- that indicates that I derives from the predefined type integer. @@ -918,6 +917,25 @@ package body Xref_Lib is Ptr := Ptr + 1; Parse_Number (Ali, Ptr, P_Column); + -- Skip the information for generics instantiations + + if Ali (Ptr) = '[' then + declare + Num_Brackets : Natural := 1; + begin + while Num_Brackets /= 0 loop + Ptr := Ptr + 1; + if Ali (Ptr) = '[' then + Num_Brackets := Num_Brackets + 1; + elsif Ali (Ptr) = ']' then + Num_Brackets := Num_Brackets - 1; + end if; + end loop; + + Ptr := Ptr + 1; + end; + end if; + -- Skip '>', or ')' or '>' Ptr := Ptr + 1; @@ -928,8 +946,7 @@ package body Xref_Lib is if Der_Info or else Type_Tree then declare Symbol : constant String := - Get_Symbol_Name (P_Eun, P_Line, P_Column); - + Get_Symbol_Name (P_Eun, P_Line, P_Column); begin if Symbol /= "???" then Add_Parent |