diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 49 | ||||
| -rw-r--r-- | gcc/ada/ali.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/decl.c | 29 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 94 | ||||
| -rw-r--r-- | gcc/ada/gnatls.adb | 47 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 275 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 92 | ||||
| -rw-r--r-- | 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 <hainque@act-europe.fr> + + * decl.c (gnat_to_gnu_entity) <E_Variable>: 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 <quinot@act-europe.fr> + + * 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 <celier@gnat.com> + + * 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 <schonberg@gnat.com> + + * 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 <schonberg@gnat.com> + + 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 <rth@redhat.com> * 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) |