diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-04-17 11:24:31 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-04-17 11:24:31 +0200 |
commit | 93bcda233f11648dbf583a9f0e50af387594d78a (patch) | |
tree | 3f29dc65f74494cef564daa36014a76c44be4d21 | |
parent | ba4a2f78eeb327397844448956bcc7abd5729050 (diff) | |
download | gcc-93bcda233f11648dbf583a9f0e50af387594d78a.zip gcc-93bcda233f11648dbf583a9f0e50af387594d78a.tar.gz gcc-93bcda233f11648dbf583a9f0e50af387594d78a.tar.bz2 |
[multiple changes]
2009-04-17 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Add documentation about No_Streams restriction
* sem_attr.adb (Check_Stream_Attribute): Exclude implicit stream
attributes when checking No_Streams restriction.
2009-04-17 Thomas Quinot <quinot@adacore.com>
* rtsfind.ads (RE_Request_Destroy): New PolyORB s-parint entity.
* exp_dist.adb (PolyORB_Support.Build_General_Calling_Stubs): Add
missing calls to RE_Request_Destroy to deallocate request objects after
use.
2009-04-17 Nicolas Setton <setton@adacore.com>
* link.c: Fix support for passing a response file under Darwin.
2009-04-17 Emmanuel Briot <briot@adacore.com>
* prj.adb (Free): new subprogram.
2009-04-17 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb: additional initialization on incomplete subtypes.
* sem_ch6.adb (Process_Formals): if the subprogram is in the private
part and one of the formals is an incomplete tagged type, attach to
list of private dependends of the type for later validation.
* sem_ch7.adb (Uninstall_Declarations): diagnose attempts to declare
primitive operations of a Taft-amendmment type.
* freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
type. The check is performed on package exit, possibly after the
subprogram is frozen.
2009-04-17 Vincent Celier <celier@adacore.com>
* prj-nmsc.adb (Get_Directories): Get the object and exec directory
before looking for source directories, but make sure that there are nil
if they are not explicitely declared and there is explicitely no
sources in the project.
From-SVN: r146227
-rw-r--r-- | gcc/ada/ChangeLog | 45 | ||||
-rw-r--r-- | gcc/ada/exp_dist.adb | 89 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 46 | ||||
-rw-r--r-- | gcc/ada/gnat_rm.texi | 6 | ||||
-rw-r--r-- | gcc/ada/link.c | 4 | ||||
-rw-r--r-- | gcc/ada/prj-nmsc.adb | 279 | ||||
-rw-r--r-- | gcc/ada/prj.adb | 34 | ||||
-rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 13 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 16 | ||||
-rw-r--r-- | gcc/ada/sem_ch7.adb | 23 |
12 files changed, 346 insertions, 227 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9b46c6..6e3db14 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2009-04-17 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add documentation about No_Streams restriction + + * sem_attr.adb (Check_Stream_Attribute): Exclude implicit stream + attributes when checking No_Streams restriction. + +2009-04-17 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads (RE_Request_Destroy): New PolyORB s-parint entity. + + * exp_dist.adb (PolyORB_Support.Build_General_Calling_Stubs): Add + missing calls to RE_Request_Destroy to deallocate request objects after + use. + +2009-04-17 Nicolas Setton <setton@adacore.com> + + * link.c: Fix support for passing a response file under Darwin. + +2009-04-17 Emmanuel Briot <briot@adacore.com> + + * prj.adb (Free): new subprogram. + +2009-04-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: additional initialization on incomplete subtypes. + + * sem_ch6.adb (Process_Formals): if the subprogram is in the private + part and one of the formals is an incomplete tagged type, attach to + list of private dependends of the type for later validation. + + * sem_ch7.adb (Uninstall_Declarations): diagnose attempts to declare + primitive operations of a Taft-amendmment type. + + * freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete + type. The check is performed on package exit, possibly after the + subprogram is frozen. + +2009-04-17 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Get_Directories): Get the object and exec directory + before looking for source directories, but make sure that there are nil + if they are not explicitely declared and there is explicitely no + sources in the project. + 2009-04-17 Pascal Obry <obry@adacore.com> * initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows. diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 58a128e6..f1ddc00 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -7157,13 +7157,37 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Nod); + Request : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + -- The request object constructed by these stubs + -- Could we use Name_R instead??? (see GLADE client stubs) + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id; + -- Generate a procedure call statement calling RE with the given + -- actuals. Request is appended to the list. + + --------------------------- + -- Make_Request_RTE_Call -- + --------------------------- + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id + is + begin + Append_To (Actuals, New_Occurrence_Of (Request, Loc)); + return Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE), Loc), + Parameter_Associations => Actuals); + end Make_Request_RTE_Call; + Arguments : Node_Id; -- Name of the named values list used to transmit parameters -- to the remote package - Request : Node_Id; - -- The request object constructed by these stubs - Result : Node_Id; -- Name of the result named value (in non-APC cases) which get the -- result of the remote subprogram. @@ -7194,8 +7218,8 @@ package body Exp_Dist is -- after the regular statements for writing out parameters. After_Statements : constant List_Id := New_List; - -- Statements to be executed after call returns (to assign - -- in out or out parameter values). + -- Statements to be executed after call returns (to assign IN OUT or + -- OUT parameter values). Etyp : Entity_Id; -- The type of the formal parameter being processed @@ -7209,7 +7233,6 @@ package body Exp_Dist is begin -- ??? document general form of stub subprograms for the PolyORB case - Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Append_To (Decls, Make_Object_Declaration (Loc, @@ -7449,19 +7472,13 @@ package body Exp_Dist is Append_List_To (Statements, Extra_Formal_Statements); Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Create), Loc), - - Parameter_Associations => New_List ( - Target_Object, - Subprogram_Id, - New_Occurrence_Of (Arguments, Loc), - New_Occurrence_Of (Result, Loc), - New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); - - Append_To (Parameter_Associations (Last (Statements)), - New_Occurrence_Of (Request, Loc)); + Make_Request_RTE_Call (RE_Request_Create, New_List ( + Target_Object, + Subprogram_Id, + New_Occurrence_Of (Arguments, Loc), + New_Occurrence_Of (Result, Loc), + New_Occurrence_Of + (RTE (RE_Nil_Exc_List), Loc)))); pragma Assert (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); @@ -7487,22 +7504,22 @@ package body Exp_Dist is RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), Expressions => New_List (Asynchronous_P))); - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Invoke), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Request, Loc)))); + Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); - Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); - Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); + -- Asynchronous case - if not Is_Known_Asynchronous then + if not Is_Known_Non_Asynchronous then + Asynchronous_Statements := + New_List (Make_Request_RTE_Call (RE_Request_Destroy)); + end if; + -- Non-asynchronous case + + if not Is_Known_Asynchronous then -- Reraise an exception occurrence from the completed request. -- If the exception occurrence is empty, this is a no-op. - Append_To (Non_Asynchronous_Statements, + Non_Asynchronous_Statements := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), @@ -7511,6 +7528,9 @@ package body Exp_Dist is if Is_Function then + Append_To (Non_Asynchronous_Statements, + Make_Request_RTE_Call (RE_Request_Destroy)); + -- If this is a function call, read the value and return it Append_To (Non_Asynchronous_Statements, @@ -7522,11 +7542,18 @@ package body Exp_Dist is Prefix => Result, Selector_Name => Name_Argument), Decls)))); + + else + + -- Case of a procedure: deal with IN OUT and OUT formals + + Append_List_To (Non_Asynchronous_Statements, After_Statements); + + Append_To (Non_Asynchronous_Statements, + Make_Request_RTE_Call (RE_Request_Destroy)); end if; end if; - Append_List_To (Non_Asynchronous_Statements, After_Statements); - if Is_Known_Asynchronous then Append_List_To (Statements, Asynchronous_Statements); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bc8e56c..9530c75 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2483,36 +2483,17 @@ package body Freeze is Error_Msg_Qual_Level := 0; end if; - -- Ada 2005 (AI-326): Check wrong use of tag incomplete - -- types with unknown discriminants. For example: - - -- type T (<>) is tagged; - -- procedure P (X : access T); -- ERROR - -- procedure P (X : T); -- ERROR - if not From_With_Type (F_Type) then if Is_Access_Type (F_Type) then F_Type := Designated_Type (F_Type); end if; - if Ekind (F_Type) = E_Incomplete_Type - and then Is_Tagged_Type (F_Type) - and then not Is_Class_Wide_Type (F_Type) - and then No (Full_View (F_Type)) - and then Unknown_Discriminants_Present - (Parent (F_Type)) - and then No (Stored_Constraint (F_Type)) - then - Error_Msg_N - ("(Ada 2005): invalid use of unconstrained tagged" - & " incomplete type", E); - -- If the formal is an anonymous_access_to_subprogram -- freeze the subprogram type as well, to prevent -- scope anomalies in gigi, because there is no other -- clear point at which it could be frozen. - elsif Is_Itype (Etype (Formal)) + if Is_Itype (Etype (Formal)) and then Ekind (F_Type) = E_Subprogram_Type then Freeze_And_Append (F_Type, Loc, Result); @@ -2522,7 +2503,7 @@ package body Freeze is Next_Formal (Formal); end loop; - -- Case of function + -- Case of function: similar checks on return type. if Ekind (E) = E_Function then @@ -2594,34 +2575,17 @@ package body Freeze is end if; end if; - if Is_Array_Type (Etype (E)) - and then not Is_Constrained (Etype (E)) + if Is_Array_Type (R_Type) + and then not Is_Constrained (R_Type) and then not Is_Imported (E) and then Has_Foreign_Convention (E) and then Warn_On_Export_Import and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (Etype (E)) + and then not Has_Warnings_Off (R_Type) then Error_Msg_N ("?foreign convention function& should not " & "return unconstrained array!", E); - - -- Ada 2005 (AI-326): Check wrong use of - -- incomplete type - - -- type T; -- tagged or just incomplete. - -- function F (X : Boolean) return T; -- ERROR - - -- The type must be declared in the current scope for the - -- use to be legal, and the full view must be available - -- when the construct that mentions it is frozen. - - elsif Ekind (Etype (E)) = E_Incomplete_Type - and then No (Full_View (Etype (E))) - and then not Is_Value_Type (Etype (E)) - then - Error_Msg_NE - ("invalid use of incomplete type&", E, Etype (E)); end if; end if; end; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3c45af2..9ce6255 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8610,6 +8610,12 @@ This restriction does not forbid dependences on the package as long as no actual stream objects are created and no stream attributes are used. +Note that the use of restriction allows optimization of tagged types, +since they do not need to worry about dispatching stream operations. +To take maximum advantage of this space-saving optimization, any +unit declaring a tagged type should be compiled with the restriction, +though this is not required. + @item No_Task_Attributes_Package @findex No_Task_Attributes_Package This restriction ensures at compile time that there are no implicit or diff --git a/gcc/ada/link.c b/gcc/ada/link.c index e1d86fc..5dd2c80 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -153,12 +153,12 @@ unsigned char __gnat_using_gnu_linker = 1; const char *__gnat_object_library_extension = ".a"; #elif defined (__APPLE__) -const char *__gnat_object_file_option = ""; +const char *__gnat_object_file_option = "-Wl,-filelist,"; const char *__gnat_run_path_option = "-Wl,-rpath,"; char __gnat_shared_libgnat_default = STATIC; int __gnat_link_max = 262144; unsigned char __gnat_objlist_file_supported = 1; -unsigned char __gnat_using_gnu_linker = 1; +unsigned char __gnat_using_gnu_linker = 0; const char *__gnat_object_library_extension = ".a"; #elif defined (linux) || defined(__GLIBC__) diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index d27f0db..ce5eccf 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -5796,6 +5796,10 @@ package body Prj.Nmsc is Util.Value_Of (Name_Source_Files, Data.Decl.Attributes, In_Tree); + Languages : constant Variable_Value := + Prj.Util.Value_Of + (Name_Languages, Data.Decl.Attributes, In_Tree); + Last_Source_Dir : String_List_Id := Nil_String; procedure Find_Source_Dirs @@ -6217,154 +6221,25 @@ package body Prj.Nmsc is Write_Line ("Starting to look for directories"); end if; - -- We set the object directory to its default. It may be set to nil, if - -- there is no sources in the project. - - Data.Object_Directory := Data.Directory; - - -- Look for the source directories - - if Current_Verbosity = High then - Write_Line ("Starting to look for source directories"); - end if; - - pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); + -- Set the object directory to its default which may be nil, if there + -- is no sources in the project. - if (not Source_Files.Default) and then - Source_Files.Values = Nil_String + if (((not Source_Files.Default) + and then Source_Files.Values = Nil_String) + or else + ((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String) + or else + ((not Languages.Default) and then Languages.Values = Nil_String)) + and then Data.Extends = No_Project then - Data.Source_Dirs := Nil_String; - - if Data.Qualifier = Standard then - Error_Msg - (Project, - In_Tree, - "a standard project cannot have no sources", - Source_Files.Location); - end if; - - if Data.Extends = No_Project - and then Data.Object_Directory = Data.Directory - then - Data.Object_Directory := No_Path_Information; - end if; - - elsif Source_Dirs.Default then - - -- No Source_Dirs specified: the single source directory is the one - -- containing the project file - - String_Element_Table.Increment_Last - (In_Tree.String_Elements); - Data.Source_Dirs := String_Element_Table.Last - (In_Tree.String_Elements); - In_Tree.String_Elements.Table (Data.Source_Dirs) := - (Value => Name_Id (Data.Directory.Name), - Display_Value => Name_Id (Data.Directory.Display_Name), - Location => No_Location, - Flag => False, - Next => Nil_String, - Index => 0); - - if Current_Verbosity = High then - Write_Line ("Single source directory:"); - Write_Str (" """); - Write_Str (Get_Name_String (Data.Directory.Display_Name)); - Write_Line (""""); - end if; - - elsif Source_Dirs.Values = Nil_String then - if Data.Qualifier = Standard then - Error_Msg - (Project, - In_Tree, - "a standard project cannot have no source directories", - Source_Dirs.Location); - end if; - - -- If Source_Dirs is an empty string list, this means that this - -- project contains no source. For projects that don't extend other - -- projects, this also means that there is no need for an object - -- directory, if not specified. - - if Data.Extends = No_Project - and then Data.Object_Directory = Data.Directory - then - Data.Object_Directory := No_Path_Information; - end if; - - Data.Source_Dirs := Nil_String; + Data.Object_Directory := No_Path_Information; else - declare - Source_Dir : String_List_Id; - Element : String_Element; - - begin - -- Process the source directories for each element of the list - - Source_Dir := Source_Dirs.Values; - while Source_Dir /= Nil_String loop - Element := In_Tree.String_Elements.Table (Source_Dir); - Find_Source_Dirs - (File_Name_Type (Element.Value), Element.Location); - Source_Dir := Element.Next; - end loop; - end; - end if; - - if not Excluded_Source_Dirs.Default - and then Excluded_Source_Dirs.Values /= Nil_String - then - declare - Source_Dir : String_List_Id; - Element : String_Element; - - begin - -- Process the source directories for each element of the list - - Source_Dir := Excluded_Source_Dirs.Values; - while Source_Dir /= Nil_String loop - Element := In_Tree.String_Elements.Table (Source_Dir); - Find_Source_Dirs - (File_Name_Type (Element.Value), - Element.Location, - Removed => True); - Source_Dir := Element.Next; - end loop; - end; - end if; - - if Current_Verbosity = High then - Write_Line ("Putting source directories in canonical cases"); + Data.Object_Directory := Data.Directory; end if; - declare - Current : String_List_Id := Data.Source_Dirs; - Element : String_Element; - - begin - while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); - if Element.Value /= No_Name then - if not Osint.File_Names_Case_Sensitive then - Get_Name_String (Element.Value); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Element.Value := Name_Find; - end if; - - In_Tree.String_Elements.Table (Current) := Element; - end if; - - Current := Element.Next; - end loop; - end; - -- Check the object directory - pragma Assert (Object_Dir.Kind = Single, - "Object_Dir is not a single string"); - if Object_Dir.Value /= Empty_String then Get_Name_String (Object_Dir.Value); @@ -6452,9 +6327,6 @@ package body Prj.Nmsc is -- Check the exec directory - pragma Assert (Exec_Dir.Kind = Single, - "Exec_Dir is not a single string"); - -- We set the object directory to its default Data.Exec_Directory := Data.Object_Directory; @@ -6502,6 +6374,127 @@ package body Prj.Nmsc is Write_Line (""""); end if; end if; + + -- Look for the source directories + + if Current_Verbosity = High then + Write_Line ("Starting to look for source directories"); + end if; + + pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); + + if (not Source_Files.Default) and then + Source_Files.Values = Nil_String + then + Data.Source_Dirs := Nil_String; + + if Data.Qualifier = Standard then + Error_Msg + (Project, + In_Tree, + "a standard project cannot have no sources", + Source_Files.Location); + end if; + + elsif Source_Dirs.Default then + + -- No Source_Dirs specified: the single source directory is the one + -- containing the project file + + String_Element_Table.Increment_Last + (In_Tree.String_Elements); + Data.Source_Dirs := String_Element_Table.Last + (In_Tree.String_Elements); + In_Tree.String_Elements.Table (Data.Source_Dirs) := + (Value => Name_Id (Data.Directory.Name), + Display_Value => Name_Id (Data.Directory.Display_Name), + Location => No_Location, + Flag => False, + Next => Nil_String, + Index => 0); + + if Current_Verbosity = High then + Write_Line ("Single source directory:"); + Write_Str (" """); + Write_Str (Get_Name_String (Data.Directory.Display_Name)); + Write_Line (""""); + end if; + + elsif Source_Dirs.Values = Nil_String then + if Data.Qualifier = Standard then + Error_Msg + (Project, + In_Tree, + "a standard project cannot have no source directories", + Source_Dirs.Location); + end if; + + Data.Source_Dirs := Nil_String; + + else + declare + Source_Dir : String_List_Id; + Element : String_Element; + + begin + -- Process the source directories for each element of the list + + Source_Dir := Source_Dirs.Values; + while Source_Dir /= Nil_String loop + Element := In_Tree.String_Elements.Table (Source_Dir); + Find_Source_Dirs + (File_Name_Type (Element.Value), Element.Location); + Source_Dir := Element.Next; + end loop; + end; + end if; + + if not Excluded_Source_Dirs.Default + and then Excluded_Source_Dirs.Values /= Nil_String + then + declare + Source_Dir : String_List_Id; + Element : String_Element; + + begin + -- Process the source directories for each element of the list + + Source_Dir := Excluded_Source_Dirs.Values; + while Source_Dir /= Nil_String loop + Element := In_Tree.String_Elements.Table (Source_Dir); + Find_Source_Dirs + (File_Name_Type (Element.Value), + Element.Location, + Removed => True); + Source_Dir := Element.Next; + end loop; + end; + end if; + + if Current_Verbosity = High then + Write_Line ("Putting source directories in canonical cases"); + end if; + + declare + Current : String_List_Id := Data.Source_Dirs; + Element : String_Element; + + begin + while Current /= Nil_String loop + Element := In_Tree.String_Elements.Table (Current); + if Element.Value /= No_Name then + if not Osint.File_Names_Case_Sensitive then + Get_Name_String (Element.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Element.Value := Name_Find; + end if; + + In_Tree.String_Elements.Table (Current) := Element; + end if; + + Current := Element.Next; + end loop; + end; end Get_Directories; --------------- diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 6c26bc1..e97f1af 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -161,6 +161,9 @@ package body Prj is -- Table to store the path name of all the created temporary files, so that -- they can be deleted at the end, or when the program is interrupted. + procedure Free (Project : in out Project_Data); + -- Free memory allocated for Project + ------------------- -- Add_To_Buffer -- ------------------- @@ -831,6 +834,19 @@ package body Prj is -- Free -- ---------- + procedure Free (Project : in out Project_Data) is + begin + Free (Project.Dir_Path); + Free (Project.Include_Path); + Free (Project.Ada_Include_Path); + Free (Project.Objects_Path); + Free (Project.Ada_Objects_Path); + end Free; + + ---------- + -- Free -- + ---------- + procedure Free (Tree : in out Project_Tree_Ref) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref); @@ -844,7 +860,6 @@ package body Prj is Array_Table.Free (Tree.Arrays); Package_Table.Free (Tree.Packages); Project_List_Table.Free (Tree.Project_Lists); - Project_Table.Free (Tree.Projects); Source_Data_Table.Free (Tree.Sources); Alternate_Language_Table.Free (Tree.Alt_Langs); Unit_Table.Free (Tree.Units); @@ -853,6 +868,13 @@ package body Prj is Source_Paths_Htable.Reset (Tree.Source_Paths_HT); Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); + for P in Project_Table.First .. + Project_Table.Last (Tree.Projects) + loop + Free (Tree.Projects.Table (P)); + end loop; + Project_Table.Free (Tree.Projects); + -- Private part Naming_Table.Free (Tree.Private_Part.Namings); @@ -885,7 +907,6 @@ package body Prj is Array_Table.Init (Tree.Arrays); Package_Table.Init (Tree.Packages); Project_List_Table.Init (Tree.Project_Lists); - Project_Table.Init (Tree.Projects); Source_Data_Table.Init (Tree.Sources); Alternate_Language_Table.Init (Tree.Alt_Langs); Unit_Table.Init (Tree.Units); @@ -894,6 +915,15 @@ package body Prj is Source_Paths_Htable.Reset (Tree.Source_Paths_HT); Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); + if not Project_Table."=" (Tree.Projects.Table, null) then + for P in Project_Table.First .. + Project_Table.Last (Tree.Projects) + loop + Free (Tree.Projects.Table (P)); + end loop; + end if; + Project_Table.Init (Tree.Projects); + -- Private part table Naming_Table.Init (Tree.Private_Part.Namings); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index b9be1d5..f3dd176 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1151,6 +1151,7 @@ package Rtsfind is RE_Request_Arguments, -- System.Partition_Interface RE_Request_Set_Out, -- System.Partition_Interface RE_Request_Raise_Occurrence, -- System.Partition_Interface + RE_Request_Destroy, -- System.Partition_Interface RE_Nil_Exc_List, -- System.Partition_Interface RE_Servant, -- System.Partition_Interface RE_Move_Any_Value, -- System.Partition_Interface @@ -2294,6 +2295,7 @@ package Rtsfind is RE_Request_Arguments => System_Partition_Interface, RE_Request_Set_Out => System_Partition_Interface, RE_Request_Raise_Occurrence => System_Partition_Interface, + RE_Request_Destroy => System_Partition_Interface, RE_Nil_Exc_List => System_Partition_Interface, RE_Servant => System_Partition_Interface, RE_Move_Any_Value => System_Partition_Interface, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index c043c4f..38f45a8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1557,7 +1557,17 @@ package body Sem_Attr is -- Check restriction violations - Check_Restriction (No_Streams, P); + -- First check the No_Streams restriction, which prohibits the use + -- of explicit stream attributes in the source program. We do not + -- prevent the occurrence of stream attributes in generated code, + -- for instance those generated implicitly for dispatching purposes. + + if Comes_From_Source (N) then + Check_Restriction (No_Streams, P); + end if; + + -- Check special case of Exception_Id and Exception_Occurrence which + -- are not allowed for restriction No_Exception_Regstriation. if Is_RTE (P_Type, RE_Exception_Id) or else @@ -2061,6 +2071,7 @@ package body Sem_Attr is Rewrite (N, Make_Raise_Program_Error (Loc, Reason => PE_Address_Of_Intrinsic)); + else Error_Msg_N ("cannot take Address of intrinsic subprogram", N); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 765adb3..5a105db 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -7230,10 +7230,11 @@ package body Sem_Ch3 is Set_Etype (Derived_Type, Parent_Base); Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); - Set_Size_Info (Derived_Type, Parent_Type); - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); - Set_Convention (Derived_Type, Convention (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Size_Info (Derived_Type, Parent_Type); + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Convention (Derived_Type, Convention (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); -- The derived type inherits the representation clauses of the parent. -- However, for a private type that is completed by a derivation, there @@ -13502,6 +13503,9 @@ package body Sem_Ch3 is Error_Msg_NE ( "full declaration of } must be a record extension", Prev, Id); + + -- Set some attributes to produce a usable full view. + Set_Is_Tagged_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); end if; @@ -16849,6 +16853,10 @@ package body Sem_Ch3 is E_Incomplete_Type => Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + if Ekind (Def_Id) = E_Incomplete_Type then + Set_Private_Dependents (Def_Id, New_Elmt_List); + end if; + when Private_Kind => Constrain_Discriminated_Type (Def_Id, S, Related_Nod); Set_Private_Dependents (Def_Id, New_Elmt_List); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 576f9cd..2606940 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7703,10 +7703,22 @@ package body Sem_Ch6 is (Is_Class_Wide_Type (Formal_Type) and then Is_Incomplete_Type (Root_Type (Formal_Type))) then - -- Ada 2005 (AI-326): Tagged incomplete types allowed + -- Ada 2005 (AI-326): Tagged incomplete types allowed in + -- primitive operations, as long as their completion is + -- in the same declarative part. If in the private part + -- this means that the type cannot be a Taft-amendment type. + -- Check is done on package exit. if Is_Tagged_Type (Formal_Type) then - null; + if Ekind (Scope (Current_Scope)) = E_Package + and then In_Private_Part (Scope (Current_Scope)) + and then not From_With_Type (Formal_Type) + and then not Is_Class_Wide_Type (Formal_Type) + then + Append_Elmt + (Current_Scope, + Private_Dependents (Base_Type (Formal_Type))); + end if; -- Special handling of Value_Type for CIL case diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 7b9edd4..7e84f7b 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2261,12 +2261,33 @@ package body Sem_Ch7 is end if; elsif Ekind (Id) = E_Incomplete_Type + and then Comes_From_Source (Id) and then No (Full_View (Id)) then - -- Mark Taft amendment types + + -- Mark Taft amendment types. Verify that there are no + -- primitive operations declared for the type (3.10.1 (9)). Set_Has_Completion_In_Body (Id); + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Private_Dependents (Id)); + while Present (Elmt) loop + Subp := Node (Elmt); + if Is_Overloadable (Subp) then + Error_Msg_NE + ("type& must be completed in the private part", + Parent (Subp), Id); + end if; + + Next_Elmt (Elmt); + end loop; + end; + elsif not Is_Child_Unit (Id) and then (not Is_Private_Type (Id) or else No (Full_View (Id))) |