From 244e5a2c23e5477e26f1970afb1fa0772b2cc808 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 13 Aug 2004 12:24:46 +0200 Subject: [PATCH] [multiple changes] 2004-08-13 Olivier Hainque * decl.c (gnat_to_gnu_entity) : When building an allocator for a global aliased object with a variable size and an unconstrained nominal subtype, pretend there is no initializer if the one we have is incomplete, and avoid referencing an inexistant component in there. The part we have will be rebuilt anyway and the reference may confuse further operations. 2004-08-13 Thomas Quinot * einfo.ads: Minor reformatting * lib-writ.adb (Output_Main_Program_Line): Do not set parameter restrictions in the ALI if we only want to warn about violations. 2004-08-13 Vincent Celier * ali.adb (Scan_ALI): Initialize component Body_Needed_For_SAL to False when creating a new Unit_Record in table Units. * gnatls.adb (Output_Unit): In verbose mode, output the restrictions that are violated, if any. * prj-nmsc.adb (Ada_Check.Get_Path_Names_And_Record_Sources): Do not add directory separator if path already ends with a directory separator. 2004-08-13 Ed Schonberg * rtsfind.adb (Entity_Not_Defined): If the error ocurrs in a predefined unit, this is an attempt to inline a construct that is not available in the current restricted mode, so abort rather than trying to continue. * sem_ch3.adb (Build_Underlying_Full_View): If the new type has discriminants that rename those of the parent, recover names of original discriminants for the constraint on the full view of the parent. (Complete_Private_Subtype): Do not create a subtype declaration if the subtype is an itype. * gnat_rm.texi: Added section on implementation of discriminated records with default values for discriminants. 2004-08-13 Ed Schonberg PR ada/15601 * sem_res.adb (Make_Call_Into_Operator): Handle properly the case where the second operand is overloaded. From-SVN: r85934 --- gcc/ada/ChangeLog | 49 ++++++++ gcc/ada/ali.adb | 1 + gcc/ada/decl.c | 29 +++-- gcc/ada/einfo.ads | 2 +- gcc/ada/gnat_rm.texi | 94 +++++++++++++++ gcc/ada/gnatls.adb | 47 +++++++- gcc/ada/lib-writ.adb | 4 +- gcc/ada/prj-nmsc.adb | 275 ++++++++++++++++++------------------------- gcc/ada/rtsfind.adb | 18 ++- gcc/ada/sem_ch3.adb | 92 +++++++++++---- gcc/ada/sem_res.adb | 6 +- 11 files changed, 412 insertions(+), 205 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9cb2dfdb4a9..2819c7b0052 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,52 @@ +2004-08-13 Olivier Hainque + + * decl.c (gnat_to_gnu_entity) : When building an allocator + for a global aliased object with a variable size and an unconstrained + nominal subtype, pretend there is no initializer if the one we have is + incomplete, and avoid referencing an inexistant component in there. The + part we have will be rebuilt anyway and the reference may confuse + further operations. + +2004-08-13 Thomas Quinot + + * einfo.ads: Minor reformatting + + * lib-writ.adb (Output_Main_Program_Line): Do not set parameter + restrictions in the ALI if we only want to warn about violations. + +2004-08-13 Vincent Celier + + * ali.adb (Scan_ALI): Initialize component Body_Needed_For_SAL to False + when creating a new Unit_Record in table Units. + + * gnatls.adb (Output_Unit): In verbose mode, output the restrictions + that are violated, if any. + + * prj-nmsc.adb (Ada_Check.Get_Path_Names_And_Record_Sources): Do not + add directory separator if path already ends with a directory separator. + +2004-08-13 Ed Schonberg + + * rtsfind.adb (Entity_Not_Defined): If the error ocurrs in a predefined + unit, this is an attempt to inline a construct that is not available in + the current restricted mode, so abort rather than trying to continue. + + * sem_ch3.adb (Build_Underlying_Full_View): If the new type has + discriminants that rename those of the parent, recover names of + original discriminants for the constraint on the full view of the + parent. + (Complete_Private_Subtype): Do not create a subtype declaration if the + subtype is an itype. + + * gnat_rm.texi: Added section on implementation of discriminated + records with default values for discriminants. + +2004-08-13 Ed Schonberg + + PR ada/15601 + * sem_res.adb (Make_Call_Into_Operator): Handle properly the case where + the second operand is overloaded. + 2004-08-10 Richard Henderson * utils.c (gnat_install_builtins): Remove __builtin_stack_alloc, diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 28d02cc79ec..3326ecaafad 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -1173,6 +1173,7 @@ package body ALI is Units.Table (Units.Last).First_Arg := First_Arg; Units.Table (Units.Last).Elab_Position := 0; Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface; + Units.Table (Units.Last).Body_Needed_For_SAL := False; if Debug_Flag_U then Write_Str (" ----> reading unit "); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 702e348acdb..a3a70002706 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -922,11 +922,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) used_by_ref = true; const_flag = true; - /* Get the data part of GNU_EXPR in case this was a - aliased object whose nominal subtype is unconstrained. - In that case the pointer above will be a thin pointer and - build_allocator will automatically make the template and - constructor already made above. */ + /* In case this was a aliased object whose nominal subtype is + unconstrained, the pointer above will be a thin pointer and + build_allocator will automatically make the template. + + If we have a template initializer only (that we made above), + pretend there is none and rely on what build_allocator creates + again anyway. Otherwise (if we have a full initializer), get + the data part and feed that to build_allocator. */ if (definition) { @@ -937,11 +940,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { gnu_alloc_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); - gnu_expr - = build_component_ref - (gnu_expr, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), - false); + + if (TREE_CODE (gnu_expr) == CONSTRUCTOR + && + TREE_CHAIN (CONSTRUCTOR_ELTS (gnu_expr)) == NULL_TREE) + gnu_expr = 0; + else + gnu_expr + = build_component_ref + (gnu_expr, NULL_TREE, + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), + false); } if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 5ebe8dad72b..2b467419e1e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3088,7 +3088,7 @@ package Einfo is -- Present in private subtypes that are the completion of other private -- types, or in private types that are derived from private subtypes. -- If the full view of a private type T is derived from another --- private type with discriminants Td, the full view of T is also +-- private type with discriminants Td, the full view of T is also -- private, and there is no way to attach to it a further full view that -- would convey the structure of T to the back end. The Underlying_Full_ -- View is an attribute of the full view that is a subtype of Td with diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index d3d28367e88..82c390ab34f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -380,6 +380,7 @@ Implementation of Specific Ada Features * GNAT Implementation of Tasking:: * GNAT Implementation of Shared Passive Packages:: * Code Generation for Array Aggregates:: +* The Size of Discriminated Records with Default Discriminants:: Project File Reference @@ -12798,6 +12799,7 @@ facilities. * GNAT Implementation of Tasking:: * GNAT Implementation of Shared Passive Packages:: * Code Generation for Array Aggregates:: +* The Size of Discriminated Records with Default Discriminants:: @end menu @node Machine Code Insertions @@ -13342,6 +13344,98 @@ If any of these conditions are violated, the aggregate will be built in a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. + +@node The Size of Discriminated Records with Default Discriminants +@section The Size of Discriminated Records with Default Discriminants + +@noindent +If a discriminated type @code{T} has discriminants with default values, it is +possible to declare an object of this type without providing an explicit +constraint: + +@smallexample @c ada +@group +type Size is range 1..100; + +type Rec (D : Size := 15) is record + Name : String (1..D); +end T; + +Word : Rec; +@end group +@end smallexample + +@noindent +Such an object is said to be @emph{unconstrained}. +The discriminant of the object +can be modified by a full assignment to the object, as long as it preserves the +relation between the value of the discriminant, and the value of the components +that depend on it: + +@smallexample @c ada +@group +Word := (3, "yes"); + +Word := (5, "maybe"); + +Word := (5, "no"); -- raises Constraint_Error +@end group +@end smallexample + +@noindent +In order to support this behavior efficiently, an unconstrained object is +given the maximum size that any value of the type requires. In the case +above, @code{Word} has storage for the discriminant and for +a @code{String} of length 100. +It is important to note that unconstrained objects do not require dynamic +allocation. It would be an improper implementation to place on the heap those +components whose size depends on discriminants. (This improper implementation +was used by some Ada83 compilers, where the @code{Name} component above +would have +been stored as a pointer to a dynamic string). Following the principle that +dynamic storage management should never be introduced implicitly, +an Ada95 compiler should reserve the full size for an unconstrained declared +object, and place it on the stack. + +This maximum size approach +has been a source of surprise to some users, who expect the default +values of the discriminants to determine the size reserved for an +unconstrained object: ``If the default is 15, why should the object occupy +a larger size?'' +The answer, of course, is that the discriminant may be later modified, +and its full range of values must be taken into account. This is why the +declaration: + +@smallexample +@group +type Rec (D : Positive := 15) is record + Name : String (1..D); +end record; + +Too_Large : Rec; +@end group +@end smallexample + +@noindent +is flagged by the compiler with a warning: +an attempt to create @code{Too_Large} will raise @code{Storage_Error}, +because the required size includes @code{Positive'Last} +bytes. As the first example indicates, the proper approach is to declare an +index type of ``reasonable'' range so that unconstrained objects are not too +large. + +One final wrinkle: if the object is declared to be @code{aliased}, or if it is +created in the heap by means of an allocator, then it is @emph{not} +unconstrained: +it is constrained by the default values of the discriminants, and those values +cannot be modified by full assignment. This is because in the presence of +aliasing all views of the object (which may be manipulated by different tasks, +say) must be consistent, so it is imperative that the object, once created, +remain invariant. + + + + @node Project File Reference @chapter Project File Reference diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 30356057151..5c269916371 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -513,9 +513,11 @@ procedure Gnatls is else Write_Str ("Unit => "); - Write_Eol; Write_Str (" Name => "); + Write_Eol; + Write_Str (" Name => "); Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Eol; Write_Str (" Kind => "); + Write_Eol; + Write_Str (" Kind => "); if Units.Table (U_Id).Unit_Kind = 'p' then Write_Str ("package "); @@ -547,7 +549,8 @@ procedure Gnatls is U.Body_Needed_For_SAL or U.Elaborate_Body then - Write_Eol; Write_Str (" Flags =>"); + Write_Eol; + Write_Str (" Flags =>"); if U.Preelab then Write_Str (" Preelaborable"); @@ -631,7 +634,8 @@ procedure Gnatls is -- Display these restrictions. if Restrictions.Set /= (All_Restrictions => False) then - Write_Eol; Write_Str (" Restrictions =>"); + Write_Eol; + Write_Str (" pragma Restrictions =>"); -- For boolean restrictions, just display the name of the -- restriction; for valued restrictions, also display the @@ -650,12 +654,45 @@ procedure Gnatls is end if; end loop; end if; + + -- If the unit violates some Restrictions, display the list of + -- these restrictions. + + if Restrictions.Violated /= (All_Restrictions => False) then + Write_Eol; + Write_Str (" Restrictions violated =>"); + + -- For boolean restrictions, just display the name of the + -- restriction; for valued restrictions, also display the + -- restriction value. + + for Restriction in All_Restrictions loop + if Restrictions.Violated (Restriction) then + Write_Eol; + Write_Str (" "); + Write_Str (Image (Restriction)); + + if Restriction in All_Parameter_Restrictions then + if Restrictions.Count (Restriction) > 0 then + Write_Str (" =>"); + + if Restrictions.Unknown (Restriction) then + Write_Str (" at least"); + end if; + + Write_Str (Restrictions.Count (Restriction)'Img); + end if; + end if; + end if; + end loop; + end if; end; end if; if Print_Source then if Too_Long then - Write_Eol; Write_Str (" "); + Write_Eol; + Write_Str (" "); else Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End)); end if; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index df61c3f6154..89b4e23b210 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -958,7 +958,9 @@ package body Lib.Writ is -- And now the information for the parameter restrictions for RP in All_Parameter_Restrictions loop - if Main_Restrictions.Set (RP) then + if Main_Restrictions.Set (RP) + and then not Restriction_Warnings (RP) + then Write_Info_Char ('r'); Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); else diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 53e08531644..c3193b8098e 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -29,7 +29,6 @@ with Fmap; use Fmap; with Hostparm; with MLib.Tgt; with Namet; use Namet; -with Opt; use Opt; with Osint; use Osint; with Output; use Output; with MLib.Tgt; use MLib.Tgt; @@ -238,19 +237,15 @@ package body Prj.Nmsc is -- a spec suffix, a body suffix or a separate suffix. procedure Locate_Directory - (Name : Name_Id; - Parent : Name_Id; - Dir : out Name_Id; - Display : out Name_Id; - Project : Project_Id := No_Project; - Kind : String := ""; - Location : Source_Ptr := No_Location); - -- Locate a directory. Dir is the canonical path name. Display is the - -- path name for display purpose. - -- When the directory does not exist, Setup_Projects is True and Kind is - -- not the empty string, an attempt is made to create the directory. - -- Returns No_Name in Dir and Display if directory does not exist or - -- cannot be created. + (Name : Name_Id; + Parent : Name_Id; + Dir : out Name_Id; + Display : out Name_Id); + -- Locate a directory (returns No_Name for Dir and Display if directory + -- does not exist). Name is the directory name. Parent is the root + -- directory, if Name is a relative path name. Dir is the canonical case + -- path name of the directory, Display is the directory path name for + -- display purposes. function Path_Name_Of (File_Name : Name_Id; @@ -386,7 +381,11 @@ package body Prj.Nmsc is Source_Names.Set (Canonical_Name, NL); Name_Len := Dir_Path'Length; Name_Buffer (1 .. Name_Len) := Dir_Path; - Add_Char_To_Name_Buffer (Directory_Separator); + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); Path := Name_Find; @@ -1113,8 +1112,7 @@ package body Prj.Nmsc is -- 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. If setting up projects (gnat setup) - -- and the directory does not exist, attempt to create it. + -- the library directory. if Lib_Src_Dir.Value /= Empty_String then declare @@ -1124,18 +1122,11 @@ package body Prj.Nmsc is Locate_Directory (Dir_Id, Data.Display_Directory, Data.Library_Src_Dir, - Data.Display_Library_Src_Dir, - Project => Project, - Kind => "library interface copy", - Location => Lib_Src_Dir.Location); + Data.Display_Library_Src_Dir); - -- If directory does not exist, report an error. No need - -- to do that if Setup_Projects is True, as an error - -- has already been reported by Locate_Directory. + -- If directory does not exist, report an error - if not Setup_Projects - and then Data.Library_Src_Dir = No_Name - then + if Data.Library_Src_Dir = No_Name then -- Get the absolute name of the library directory -- that does not exist, to report an error. @@ -2526,17 +2517,15 @@ package body Prj.Nmsc is end if; if For_Language = Lang_Ada then - - -- If we have looked for sources and found none, then it is an - -- error, except if it is an extending project. If a non-extending - -- project is not supposed to contain any source, then we never - -- Find_Sources. No error is signalled when setting up projects - -- using gnat setup. + -- If we have looked for sources and found none, then + -- it is an error, except if it is an extending project. + -- If a non extending project is not supposed to contain + -- any source, then we never call Find_Sources. if Current_Source /= Nil_String then Data.Ada_Sources_Present := True; - elsif not Setup_Projects and then Data.Extends = No_Project then + elsif Data.Extends = No_Project then Error_Msg (Project, "there are no Ada sources in this project", @@ -3306,20 +3295,15 @@ package body Prj.Nmsc is Object_Dir.Location); else - -- Check that the specified object directory does exist, and - -- attempt to create it if setting up projects (gnat setup). + -- We check that the specified object directory + -- does exist. Locate_Directory (Object_Dir.Value, Data.Display_Directory, - Data.Object_Directory, Data.Display_Object_Dir, - Project => Project, Kind => "object", - Location => Object_Dir.Location); + Data.Object_Directory, Data.Display_Object_Dir); - if not Setup_Projects - and then Data.Object_Directory = No_Name - then + if Data.Object_Directory = No_Name then -- The object directory does not exist, report an error - Err_Vars.Error_Msg_Name_1 := Object_Dir.Value; Error_Msg (Project, @@ -3327,9 +3311,10 @@ package body Prj.Nmsc is Data.Location); -- Do not keep a nil Object_Directory. Set it to the - -- specified (relative or absolute) path. This is for the - -- benefit of tools that recover from errors. For example, - -- these tools could create the non-existent directory. + -- specified (relative or absolute) path. + -- This is for the benefit of tools that recover from + -- errors; for example, these tools could create the + -- non existent directory. Data.Display_Object_Dir := Object_Dir.Value; Get_Name_String (Object_Dir.Value); @@ -3376,18 +3361,14 @@ package body Prj.Nmsc is Exec_Dir.Location); else - -- We check that the specified exec directory does exist and - -- attempt to create it if setting up projects (gnat setup). + -- We check that the specified object directory + -- does exist. Locate_Directory (Exec_Dir.Value, Data.Directory, - Data.Exec_Directory, Data.Display_Exec_Dir, - Project => Project, Kind => "exec", - Location => Exec_Dir.Location); + Data.Exec_Directory, Data.Display_Exec_Dir); - if not Setup_Projects - and then Data.Exec_Directory = No_Name - then + if Data.Exec_Directory = No_Name then Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value; Error_Msg (Project, @@ -3447,10 +3428,10 @@ package body Prj.Nmsc is elsif Source_Dirs.Values = Nil_String then - -- If Source_Dirs is an empty string list, this means that this - -- contains no sources. For projects that do not extend other - -- projects, this also means that there is no need for an object - -- directory unless one is specified explicitly. + -- 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 @@ -3531,8 +3512,8 @@ package body Prj.Nmsc is begin -- If the project extended is a library project, we inherit - -- the library name, if it is not redefined, we check that - -- the library directory is specified, and we reset the + -- the library name, if it is not redefined; we check that + -- the library directory is specified; and we reset the -- library flag for the extended project. if Extended_Data.Library then @@ -3579,16 +3560,13 @@ package body Prj.Nmsc is end if; else - -- Find path name, check that it is a directory, and attempt - -- to create it if setting up projects (gnat setup). + -- Find path name, check that it is a directory Locate_Directory (Lib_Dir.Value, Data.Display_Directory, - Data.Library_Dir, Data.Display_Library_Dir, - Project => Project, Kind => "library", - Location => Lib_Dir.Location); + Data.Library_Dir, Data.Display_Library_Dir); - if not Setup_Projects and then Data.Library_Dir = No_Name then + if Data.Library_Dir = No_Name then -- Get the absolute name of the library directory that -- does not exist, to report an error. @@ -3773,26 +3751,26 @@ package body Prj.Nmsc is -- Check Spec_Suffix declare - Spec_Suffixes : Array_Element_Id := - Util.Value_Of - (Name_Spec_Suffix, - Naming.Decl.Arrays); + Spec_Suffixs : Array_Element_Id := + Util.Value_Of + (Name_Spec_Suffix, + Naming.Decl.Arrays); Suffix : Array_Element_Id; Element : Array_Element; Suffix2 : Array_Element_Id; begin - -- If some suffixes have been specified, we make sure that + -- If some suffixs have been specified, we make sure that -- for each language for which a default suffix has been -- specified, there is a suffix specified, either the one -- in the project file or if there were none, the default. - if Spec_Suffixes /= No_Array_Element then + if Spec_Suffixs /= No_Array_Element then Suffix := Data.Naming.Spec_Suffix; while Suffix /= No_Array_Element loop Element := Array_Elements.Table (Suffix); - Suffix2 := Spec_Suffixes; + Suffix2 := Spec_Suffixs; while Suffix2 /= No_Array_Element loop exit when Array_Elements.Table (Suffix2).Index = @@ -3800,8 +3778,9 @@ package body Prj.Nmsc is Suffix2 := Array_Elements.Table (Suffix2).Next; end loop; - -- There is a registered default suffix, but no suffix is - -- specified in the project file. Add default to array. + -- There is a registered default suffix, but no + -- suffix specified in the project file. + -- Add the default to the array. if Suffix2 = No_Array_Element then Array_Elements.Increment_Last; @@ -3810,16 +3789,16 @@ package body Prj.Nmsc is Src_Index => Element.Src_Index, Index_Case_Sensitive => False, Value => Element.Value, - Next => Spec_Suffixes); - Spec_Suffixes := Array_Elements.Last; + Next => Spec_Suffixs); + Spec_Suffixs := Array_Elements.Last; end if; Suffix := Element.Next; end loop; - -- Put the resulting array as the specification suffixes + -- Put the resulting array as the specification suffixs - Data.Naming.Spec_Suffix := Spec_Suffixes; + Data.Naming.Spec_Suffix := Spec_Suffixs; end if; end; @@ -3847,26 +3826,27 @@ package body Prj.Nmsc is -- Check Body_Suffix declare - Impl_Suffixes : Array_Element_Id := - Util.Value_Of - (Name_Body_Suffix, Naming.Decl.Arrays); + Impl_Suffixs : Array_Element_Id := + Util.Value_Of + (Name_Body_Suffix, + Naming.Decl.Arrays); Suffix : Array_Element_Id; Element : Array_Element; Suffix2 : Array_Element_Id; begin - -- If some suffixes have been specified, we make sure that + -- If some suffixs have been specified, we make sure that -- for each language for which a default suffix has been -- specified, there is a suffix specified, either the one -- in the project file or if there were noe, the default. - if Impl_Suffixes /= No_Array_Element then + if Impl_Suffixs /= No_Array_Element then Suffix := Data.Naming.Body_Suffix; while Suffix /= No_Array_Element loop Element := Array_Elements.Table (Suffix); - Suffix2 := Impl_Suffixes; + Suffix2 := Impl_Suffixs; while Suffix2 /= No_Array_Element loop exit when Array_Elements.Table (Suffix2).Index = @@ -3885,16 +3865,16 @@ package body Prj.Nmsc is Src_Index => Element.Src_Index, Index_Case_Sensitive => False, Value => Element.Value, - Next => Impl_Suffixes); - Impl_Suffixes := Array_Elements.Last; + Next => Impl_Suffixs); + Impl_Suffixs := Array_Elements.Last; end if; Suffix := Element.Next; end loop; - -- Put the resulting array as the implementation suffixes + -- Put the resulting array as the implementation suffixs - Data.Naming.Body_Suffix := Impl_Suffixes; + Data.Naming.Body_Suffix := Impl_Suffixs; end if; end; @@ -3941,13 +3921,10 @@ package body Prj.Nmsc is ---------------------- procedure Locate_Directory - (Name : Name_Id; - Parent : Name_Id; - Dir : out Name_Id; - Display : out Name_Id; - Project : Project_Id := No_Project; - Kind : String := ""; - Location : Source_Ptr := No_Location) + (Name : Name_Id; + Parent : Name_Id; + Dir : out Name_Id; + Display : out Name_Id) is The_Name : constant String := Get_Name_String (Name); The_Parent : constant String := @@ -3955,64 +3932,6 @@ package body Prj.Nmsc is The_Parent_Last : constant Natural := Compute_Directory_Last (The_Parent); - procedure Create_Directory (Absolute_Path : String); - -- Attempt to create a new directory - - procedure Get_Names_For (Absolute_Path : String); - -- Create name ids Dir and Display for directory Absolute_Path - - ---------------------- - -- Create_Directory -- - ---------------------- - - procedure Create_Directory (Absolute_Path : String) is - begin - -- Attempt to create the directory - - Make_Dir (Absolute_Path); - - -- Setup Dir and Display if creation was successful - - Get_Names_For (Absolute_Path); - - exception - when Directory_Error => - Error_Msg - (Project, - "could not create " & Kind & " directory """ & - Absolute_Path & """", - Location); - end Create_Directory; - - ------------------- - -- Get_Names_For -- - ------------------- - - procedure Get_Names_For (Absolute_Path : String) is - Normed : constant String := - Normalize_Pathname - (Absolute_Path, - Resolve_Links => False, - Case_Sensitive => True); - - Canonical_Path : constant String := - Normalize_Pathname - (Normed, - Resolve_Links => True, - Case_Sensitive => False); - - begin - Name_Len := Normed'Length; - Name_Buffer (1 .. Name_Len) := Normed; - Display := Name_Find; - - Name_Len := Canonical_Path'Length; - Name_Buffer (1 .. Name_Len) := Canonical_Path; - Dir := Name_Find; - end Get_Names_For; - - -- Start of processing for Locate_Directory - begin if Current_Verbosity = High then Write_Str ("Locate_Directory ("""); @@ -4027,10 +3946,28 @@ package body Prj.Nmsc is if Is_Absolute_Path (The_Name) then if Is_Directory (The_Name) then - Get_Names_For (The_Name); + declare + Normed : constant String := + Normalize_Pathname + (The_Name, + Resolve_Links => False, + Case_Sensitive => True); + + Canonical_Path : constant String := + Normalize_Pathname + (Normed, + Resolve_Links => True, + Case_Sensitive => False); - elsif Kind /= "" and then Setup_Projects then - Create_Directory (The_Name); + begin + Name_Len := Normed'Length; + Name_Buffer (1 .. Name_Len) := Normed; + Display := Name_Find; + + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; + Dir := Name_Find; + end; end if; else @@ -4041,10 +3978,28 @@ package body Prj.Nmsc is begin if Is_Directory (Full_Path) then - Get_Names_For (Full_Path); + declare + Normed : constant String := + Normalize_Pathname + (Full_Path, + Resolve_Links => False, + Case_Sensitive => True); + + Canonical_Path : constant String := + Normalize_Pathname + (Normed, + Resolve_Links => True, + Case_Sensitive => False); - elsif Kind /= "" and then Setup_Projects then - Create_Directory (Full_Path); + begin + Name_Len := Normed'Length; + Name_Buffer (1 .. Name_Len) := Normed; + Display := Name_Find; + + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; + Dir := Name_Find; + end; end if; end; end if; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 36e5bad65a0..e4d1d035949 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -186,7 +186,23 @@ package body Rtsfind is procedure Entity_Not_Defined (Id : RE_Id) is begin if No_Run_Time_Mode then - RTE_Error_Msg ("|construct not allowed in no run time mode"); + + -- If the error occurs when compiling the body of a predefined + -- unit for inlining purposes, the body must be illegal in this + -- mode, and there is no point in continuing. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (Current_Error_Node)))) + then + Error_Msg_N + ("construct not allowed in no run time mode!", + Current_Error_Node); + raise Unrecoverable_Error; + + else + RTE_Error_Msg ("|construct not allowed in no run time mode"); + end if; + elsif Configurable_Run_Time_Mode then RTE_Error_Msg ("|construct not allowed in this configuration>"); else diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 670ee7656a3..dd2e183ef84 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6288,30 +6288,60 @@ package body Sem_Ch3 is C : Node_Id; Id : Node_Id; + procedure Set_Discriminant_Name (Id : Node_Id); + -- If the derived type has discriminants, they may rename discriminants + -- of the parent. When building the full view of the parent, we need to + -- recover the names of the original discriminants if the constraint is + -- given by named associations. + + --------------------------- + -- Set_Discriminant_Name -- + --------------------------- + + procedure Set_Discriminant_Name (Id : Node_Id) is + Disc : Entity_Id; + + begin + Set_Original_Discriminant (Id, Empty); + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + + while Present (Disc) loop + if Chars (Disc) = Chars (Id) + and then Present (Corresponding_Discriminant (Disc)) + then + Set_Chars (Id, Chars (Corresponding_Discriminant (Disc))); + end if; + Next_Discriminant (Disc); + end loop; + end if; + end Set_Discriminant_Name; + + -- Start of processing for Build_Underlying_Full_View + begin if Nkind (N) = N_Full_Type_Declaration then Constr := Constraint (Subtype_Indication (Type_Definition (N))); - -- ??? ??? is this assert right, I assume so otherwise Constr - -- would not be defined below (this used to be an elsif) - - else pragma Assert (Nkind (N) = N_Subtype_Declaration); + elsif Nkind (N) = N_Subtype_Declaration then Constr := New_Copy_Tree (Constraint (Subtype_Indication (N))); - end if; - -- If the constraint has discriminant associations, the discriminant - -- entity is already set, but it denotes a discriminant of the new - -- type, not the original parent, so it must be found anew. + elsif Nkind (N) = N_Component_Declaration then + Constr := + New_Copy_Tree + (Constraint (Subtype_Indication (Component_Definition (N)))); - C := First (Constraints (Constr)); + else + raise Program_Error; + end if; + C := First (Constraints (Constr)); while Present (C) loop - if Nkind (C) = N_Discriminant_Association then Id := First (Selector_Names (C)); - while Present (Id) loop - Set_Original_Discriminant (Id, Empty); + Set_Discriminant_Name (Id); Next (Id); end loop; end if; @@ -6319,19 +6349,22 @@ package body Sem_Ch3 is Next (C); end loop; - Indic := Make_Subtype_Declaration (Loc, - Defining_Identifier => Subt, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (Par, Loc), - Constraint => New_Copy_Tree (Constr))); + Indic := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Par, Loc), + Constraint => New_Copy_Tree (Constr))); -- If this is a component subtype for an outer itype, it is not -- a list member, so simply set the parent link for analysis: if -- the enclosing type does not need to be in a declarative list, -- neither do the components. - if Is_List_Member (N) then + if Is_List_Member (N) + and then Nkind (N) /= N_Component_Declaration + then Insert_Before (N, Indic); else Set_Parent (Indic, Parent (N)); @@ -6972,19 +7005,26 @@ package body Sem_Ch3 is (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); -- If the full base is itself derived from private, build a congruent - -- subtype of its underlying type, for use by the back end. Do not - -- do this for a constrained record component, where the back-end has - -- the proper information and there is no place for the declaration. + -- subtype of its underlying type, for use by the back end. For a + -- constrained record component, the declaration cannot be placed on + -- the component list, but it must neverthess be built an analyzed, to + -- supply enough information for gigi to compute the size of component. elsif Ekind (Full_Base) in Private_Kind and then Is_Derived_Type (Full_Base) and then Has_Discriminants (Full_Base) - and then Nkind (Related_Nod) /= N_Component_Declaration and then (Ekind (Current_Scope) /= E_Record_Subtype) - and then - Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication then - Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base)); + if not Is_Itype (Priv) + and then + Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication + then + Build_Underlying_Full_View + (Parent (Priv), Full, Etype (Full_Base)); + + elsif Nkind (Related_Nod) = N_Component_Declaration then + Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); + end if; elsif Is_Record_Type (Full_Base) then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 863e96b5ab4..9e384e98023 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1173,7 +1173,11 @@ package body Sem_Res is or else Scope (Opnd_Type) /= System_Aux_Id or else Pack /= Scope (System_Aux_Id)) then - Error := True; + if not Is_Overloaded (Right_Opnd (Op_Node)) then + Error := True; + else + Error := not Operand_Type_In_Scope (Pack); + end if; elsif Pack = Standard_Standard and then not Operand_Type_In_Scope (Standard_Standard) -- 2.30.2