diff options
Diffstat (limited to 'gcc/ada')
72 files changed, 1629 insertions, 1258 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fc58e04..86629f3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2025-11-02 Eric Botcazou <ebotcazou@adacore.com> + + * locales.c (is_iso_639_3): New static function. + (c_get_language_code): Use it to validate the ISO-639-3 code + before returning it. + +2025-11-02 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/58881 + * sem_ch3.adb (Build_Derived_Private_Type): Build the underlying + full view when the derivation occurs in the public part of the + scope of the parent. + (Build_Derived_Record_Type): Propagate Has_Unknown_Discriminants + in the same circumstances. + (Constrain_Discriminated_Type): Give a specific error message for + any type with the Has_Unknown_Discriminants flag. + +2025-11-02 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/52319 + * sem_ch8.adb (End_Use_Package): Use the scope of the operator. + +2025-10-30 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/15610 + * sem_type.adb (Collect_Interps): Apply the same visibility + criterion to expanded names as Find_Expanded_Name. + +2025-10-30 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/54178 + * sem_ch12.adb (Instantiate_Object): Strip qualification to detect + aggregates used as actuals. + +2025-10-30 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/16214 + * sem_ch8.adb (Find_Expanded_Name): Consolidate and streamline the + processing required for references to instances within themselves. + 2025-10-28 Eric Botcazou <ebotcazou@adacore.com> PR ada/48039 diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ab87f54..5d242ed 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -81,7 +81,6 @@ package Aspects is Aspect_Bit_Order, Aspect_Component_Size, Aspect_Constant_Indexing, - Aspect_Constructor, -- GNAT Aspect_Contract_Cases, -- GNAT Aspect_Convention, Aspect_CPU, @@ -440,7 +439,6 @@ package Aspects is Aspect_Bit_Order => Expression, Aspect_Component_Size => Expression, Aspect_Constant_Indexing => Name, - Aspect_Constructor => Name, Aspect_Contract_Cases => Expression, Aspect_Convention => Name, Aspect_CPU => Expression, @@ -547,7 +545,6 @@ package Aspects is Aspect_Component_Size => True, Aspect_Constant_Indexing => False, Aspect_Contract_Cases => False, - Aspect_Constructor => False, Aspect_Convention => True, Aspect_CPU => False, Aspect_Default_Component_Value => True, @@ -723,7 +720,6 @@ package Aspects is Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration, Aspect_Constant_Indexing => Name_Constant_Indexing, Aspect_Contract_Cases => Name_Contract_Cases, - Aspect_Constructor => Name_Constructor, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, Aspect_CUDA_Device => Name_CUDA_Device, @@ -997,7 +993,6 @@ package Aspects is Aspect_Asynchronous => Always_Delay, Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, - Aspect_Constructor => Always_Delay, Aspect_CPU => Always_Delay, Aspect_CUDA_Device => Always_Delay, Aspect_CUDA_Global => Always_Delay, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 327bc2d..a13438a 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1005,61 +1005,49 @@ package body Atree is Old_Kind : constant Entity_Kind := Ekind (Old_N); - function Same_Node_To_Fetch_From - (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) - return Boolean; - -- True if the field should be fetched from N. For most fields, this is - -- true. However, if the field is a "root type only" field, then this is - -- true only if N is the root type. If this is false, then we should not - -- do Reinit_Field_To_Zero, and we should not fail below, because the - -- field is not vanishing from the root type. Similar comments apply to - -- "base type only" and "implementation base type only" fields. - -- - -- We need to ignore exceptions here, because in some cases, - -- Node_To_Fetch_From is being called before the relevant (root, base) - -- type has been set, so we fail some assertions. - - function Same_Node_To_Fetch_From - (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) - return Boolean is - begin - return N = Node_To_Fetch_From (N, Field); - exception - when others => return False; -- ignore the exception - end Same_Node_To_Fetch_From; - -- Start of processing for Check_Vanishing_Fields begin for J in Entity_Field_Table (Old_Kind)'Range loop declare F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J); - begin - if not Same_Node_To_Fetch_From (Old_N, F) then - null; -- no check in this case - elsif not Field_Checking.Field_Present (New_Kind, F) then - if not Field_Is_Initial_Zero (Old_N, F) then - Write_Str ("# "); - Write_Str (Osint.Get_First_Main_File_Name); - Write_Str (": "); - Write_Str (Old_Kind'Img); - Write_Str (" --> "); - Write_Str (New_Kind'Img); - Write_Str (" Nonzero field "); - Write_Str (F'Img); - Write_Str (" is vanishing "); - - if New_Kind = E_Void or else Old_Kind = E_Void then - Write_Line ("(E_Void case)"); - else - Write_Line ("(non-E_Void case)"); - end if; + Same_Node_To_Fetch_From : constant Boolean := + Old_N = Node_To_Fetch_From_If_Set (Old_N, F); + -- True if the field F should be fetched from Old_N. For most + -- fields, this is True. However, if F is a "root type only" + -- field, then it should be fetched from the root type, so this is + -- true only if Old_N is the root type. If this is False, then we + -- should not have done Reinit_Field_To_Zero, and we should not + -- fail below, because the field is not vanishing from this node. + -- We use the ..._If_Set function to avoid failing when the root + -- type has not yet been set. Similar comments apply to "base type + -- only" and "implementation base type only" fields. - Write_Str (" ...mutating node "); - Write_Int (Nat (Old_N)); - Write_Line (""); - raise Program_Error; + begin + if Same_Node_To_Fetch_From + and then not Field_Checking.Field_Present (New_Kind, F) + and then not Field_Is_Initial_Zero (Old_N, F) + then + Write_Str ("# "); + Write_Str (Osint.Get_First_Main_File_Name); + Write_Str (": "); + Write_Str (Old_Kind'Img); + Write_Str (" --> "); + Write_Str (New_Kind'Img); + Write_Str (" Nonzero field "); + Write_Str (F'Img); + Write_Str (" is vanishing "); + + if New_Kind = E_Void or else Old_Kind = E_Void then + Write_Line ("(E_Void case)"); + else + Write_Line ("(non-E_Void case)"); end if; + + Write_Str (" ...mutating node "); + Write_Int (Nat (Old_N)); + Write_Line (""); + raise Program_Error; end if; end; end loop; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index c30e5f1..39cf37e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -596,9 +596,10 @@ package body Checks is -- Note: we do not check for checks suppressed here, since that check -- was done in Sem_Ch13 when the address clause was processed. We are -- only called if checks were not suppressed. The reason for this is - -- that we have to delay the call to Apply_Alignment_Check till freeze - -- time (so that all types etc are elaborated), but we have to check - -- the status of check suppressing at the point of the address clause. + -- that we have to delay the call to Apply_Address_Clause_Check till + -- freeze time (so that all types etc are elaborated), but we have to + -- check the status of check suppressing at the point of the address + -- clause. if No (AC) or else not Check_Address_Alignment (AC) diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index cdf2b5d..8dd169a 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -298,6 +298,7 @@ package body CStand is Build_Float_Type (To, UI_To_Int (Digits_Value (From)), Float_Rep (From), UI_To_Int (Esize (From)), UI_To_Int (Alignment (From))); + Set_Is_IEEE_Extended_Precision (To, Is_IEEE_Extended_Precision (From)); end Copy_Float_Type; ---------------------- @@ -2100,17 +2101,22 @@ package body CStand is Size : Positive; Alignment : Natural) is - pragma Unreferenced (Precision); - -- See Build_Float_Type for the rationale - Ent : constant Entity_Id := New_Standard_Entity (Name); + IEEE_Extended_Precision_Size : constant := 80; begin Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent); Set_Scope (Ent, Standard_Standard); Build_Float_Type (Ent, Pos (Digs), Float_Rep, Int (Size), Nat (Alignment / 8)); + -- We mostly disregard Precision, see Build_Float_Type for the + -- rationale. The only thing we use it for is to detect 80-bit IEEE + -- extended precision, in order to adjust the behavior of 'Write. + if Precision = IEEE_Extended_Precision_Size then + Set_Is_IEEE_Extended_Precision (Ent); + end if; + Append_New_Elmt (Ent, Back_End_Float_Types); end Register_Float_Type; diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst index 7250f65..65bb187 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -1580,8 +1580,7 @@ machines with strict alignment requirements, GNAT checks (at compile time if possible, generating a warning, or at execution time with a run-time check) that the alignment is appropriate. If the run-time check fails, then ``Program_Error`` is raised. This run-time -check is suppressed if range checks are suppressed, or if the special GNAT -check Alignment_Check is suppressed, or if +check is suppressed if the GNAT check Alignment_Check is suppressed, or if ``pragma Restrictions (No_Elaboration_Code)`` is in effect. It is also suppressed by default on non-strict alignment machines (such as the x86). diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index b0acb25..6d10a7f 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2622,13 +2622,20 @@ package body Einfo.Utils is begin return T : Opt_N_Entity_Id := Base_Type_If_Set (Id) do - if Ekind (T) = E_Class_Wide_Type then + if No (T) then + null; + elsif Ekind (T) = E_Class_Wide_Type then T := Etype (T); else loop Etyp := Etype (T); - exit when No (Etyp) or else T = Etyp + if No (Etyp) then + T := Empty; + exit; + end if; + + exit when T = Etyp or else (Is_Private_Type (T) and then Etyp = Full_View (T)) or else @@ -3086,7 +3093,7 @@ package body Einfo.Utils is elsif Ekind (Id) = E_Class_Wide_Type and then From_Limited_With (Id) - and then Present (Non_Limited_View (Id)) + and then Has_Non_Limited_View (Id) then return Underlying_Type (Non_Limited_View (Id)); @@ -3118,7 +3125,7 @@ package body Einfo.Utils is -- then we return the Underlying_Type of its nonlimited view. elsif From_Limited_With (Id) - and then Present (Non_Limited_View (Id)) + and then Has_Non_Limited_View (Id) then return Underlying_Type (Non_Limited_View (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b9548a7..8e41d0f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1585,11 +1585,11 @@ package Einfo is -- type derivation. -- Has_Delayed_Aspects --- Defined in all entities. Set if the Rep_Item chain for the entity has --- one or more N_Aspect_Definition nodes chained which are not to be --- evaluated till the freeze point. The aspect definition expression --- clause has been preanalyzed to get visibility at the point of use, --- but no other action has been taken. +-- Defined in all entities. Set if the Rep_Item chain for the entity has +-- one or more N_Aspect_Definition nodes chained which are not to be +-- evaluated till the freeze point. The aspect definition expression +-- clause has been preanalyzed to get visibility at the point of use, +-- but no other action has been taken. -- Has_Delayed_Freeze -- Defined in all entities. Set to indicate that an explicit freeze @@ -1889,10 +1889,6 @@ package Einfo is -- 5. N_Range_Constraint - when the range expression uses the -- discriminant of the enclosing type. --- Has_Pragma_Controlled [implementation base type only] --- Defined in access type entities. It is set if a pragma Controlled --- applies to the access type. - -- Has_Pragma_Elaborate_Body -- Defined in all entities. Set in compilation unit entities if a -- pragma Elaborate_Body applies to the compilation unit. @@ -2383,7 +2379,7 @@ package Einfo is -- Is_Activation_Record -- Applies to E_In_Parameters generated in Exp_Unst for nested -- subprograms, to mark the added formal that carries the activation --- record created in the enclosing subprogram. +-- record created in the enclosing subprogram. Used by the llvm back end. -- Is_Actual_Subtype -- Defined on all types, true for the generated constrained subtypes @@ -2596,7 +2592,7 @@ package Einfo is -- Is_Discriminant_Check_Function -- Defined in all entities. Set only in E_Function entities for functions --- created to do discriminant checks. +-- created to do discriminant checks. Used by CodePeer. -- Is_Discriminal (synthesized) -- Applies to all entities, true for renamings of discriminants. Such @@ -3471,10 +3467,6 @@ package Einfo is -- as its corresponding record type, but whose parent is the full view -- of the parent in the original type extension. --- Is_Unimplemented --- Defined in all entities. Set for any entity to which a valid pragma --- or aspect Unimplemented applies. - -- Is_Unsigned_Type -- Defined in all types, but can be set only for discrete and fixed-point -- type and subtype entities. This flag is only valid if the entity is @@ -3552,6 +3544,15 @@ package Einfo is -- a wrapper to handle inherited class-wide pre/post conditions that call -- overridden primitives or as a wrapper of a controlling function. +-- Is_IEEE_Extended_Precision +-- Defined in floating point types and subtypes. Indicates that the type +-- corresponds to the 80-bit IEEE extended precision format. That format +-- effectively uses 80 bits per value, but we set its Size to a larger +-- value for the reasons explained in the documentation comment of +-- Build_Float_Type. We also perform some extra work to consistently set +-- the extra bits to zero in the 'Write implementation, which is why we +-- need this flag. + -- Itype_Printed -- Defined in all type and subtype entities. Set in Itypes if the Itype -- has been printed by Sprint. This is used to avoid printing an Itype @@ -3705,6 +3706,11 @@ package Einfo is -- preelaborable initialization at freeze time (this has to be deferred -- to the freeze point because of the rule about overriding Initialize). +-- Needs_Construction +-- Defined in all type and subtype entities. Set only for record type +-- entities for which at least one ancestor has specified a constructor +-- through the 'Constructor direct attribute definition. + -- Needs_Debug_Info -- Defined in all entities. Set if the entity requires normal debugging -- information to be generated. This is true of all entities that have @@ -5018,7 +5024,6 @@ package Einfo is -- Is_Thunk -- Is_Trivial_Subprogram -- Is_Unchecked_Union - -- Is_Unimplemented -- Is_Visible_Formal -- Kill_Elaboration_Checks -- Low_Bound_Tested @@ -5130,6 +5135,7 @@ package Einfo is -- May_Inherit_Delayed_Rep_Aspects -- Must_Be_On_Byte_Boundary -- Must_Have_Preelab_Init + -- Needs_Construction -- Optimize_Alignment_Space -- Optimize_Alignment_Time -- Partial_View_Has_Unknown_Discr @@ -5211,7 +5217,6 @@ package Einfo is -- Associated_Storage_Pool (root type only) -- Finalization_Collection (root type only) -- Storage_Size_Variable (base type only) - -- Has_Pragma_Controlled (base type only) -- Has_Storage_Size_Clause (base type only) -- Is_Access_Constant -- Is_Local_Anonymous_Access @@ -5529,6 +5534,7 @@ package Einfo is -- Digits_Value -- Float_Rep (Float_Rep_Kind) -- Default_Aspect_Value (base type only) + -- Is_IEEE_Extended_Precision -- Scalar_Range -- Static_Real_Or_String_Predicate -- Machine_Emax_Value (synth) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 472fbbe..220523c 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -163,8 +163,8 @@ package body Errout is procedure Set_Msg_Node (Node : Node_Id); -- Add the sequence of characters for the name associated with the given -- node to the current message. For N_Designator, N_Selected_Component, - -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is - -- included as well. + -- N_Defining_Program_Unit_Name, N_Expanded_Name, and N_Attribute_Reference + -- the Prefix is included as well. procedure Set_Posted (N : Node_Id); -- Sets the Error_Posted flag on the given node, and all its parents that @@ -3800,6 +3800,29 @@ package body Errout is Set_Msg_Node (Selector_Name (Node)); return; + when N_Attribute_Reference => + Set_Msg_Node (Prefix (Node)); + Set_Msg_Char ('''); + Get_Unqualified_Decoded_Name_String (Attribute_Name (Node)); + Adjust_Name_Case (Global_Name_Buffer, Sloc (Node)); + Set_Msg_Name_Buffer; + return; + + when N_Defining_Identifier => + + -- Handle direct attribute definitions + + if Parent_Kind (Node) in N_Subprogram_Specification + and then Original_Node (Parent (Node)) /= Parent (Node) + and then Nkind (Defining_Unit_Name + (Original_Node (Parent (Node)))) + = N_Attribute_Reference + then + Set_Msg_Node + (Defining_Unit_Name (Original_Node (Parent (Node)))); + return; + end if; + when others => null; end case; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 14a11ff..bbbe245 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1579,6 +1579,46 @@ package body Erroutc is ---------------------------- procedure Set_Msg_Insertion_Name is + procedure Replace_With_Attribute_Definition; + -- This procedure handles direct attribute definition names of the form: + -- 'D' Prefix_Name "_" Attribute_Name "_Att" + -- Specifically, it replace the current Namet.Global_Name_Buffer with an + -- all lowercase string of the prefix, and a tick attribute; at this + -- stage there is no way to recognize more than an ending attribute ??? + -- + -- Note that, at this point, it is not possible to restore the original + -- casing thus lowercase is default.a + + procedure Replace_With_Attribute_Definition is + First : constant Integer := 2; + Last : constant Integer := Name_Len - 4; + Att_Buf : Bounded_String (Max_Length => Name_Len - 7); + begin + Until_Tick : + for J in First .. Last loop + + -- J could be at the position separating the prefix from the + -- attribute name. + + if Name_Buffer (J) = '_' then + Att_Buf.Length := 0; + Append (Att_Buf, Name_Buffer (J + 1 .. Last)); + Set_Casing (Att_Buf, All_Lower_Case); + if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf)) + then + Name_Buffer (J) := '''; + exit Until_Tick; + end if; + end if; + end loop Until_Tick; + + -- Remove prefix 'D' and suffix "_Att" + + Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last); + Name_Len := Last - 1; + Set_Casing (All_Lower_Case); + end Replace_With_Attribute_Definition; + begin if Error_Msg_Name_1 = No_Name then null; @@ -1624,7 +1664,14 @@ package body Erroutc is -- Else output with surrounding quotes in proper casing mode else - Set_Casing (Identifier_Casing (Flag_Source)); + if Name_Buffer (1) = 'D' + and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att" + then + Replace_With_Attribute_Definition; + else + Set_Casing (Identifier_Casing (Flag_Source)); + end if; + Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d62b735..6b6b0ab 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4914,11 +4914,10 @@ package body Exp_Aggr is -- IP procedure. if Has_Default_Init_Comps (N) - or else Present (Constructor_Name (Ctyp)) + or else Needs_Construction (Ctyp) or else (Is_Access_Type (Ctyp) - and then Present - (Constructor_Name - (Directly_Designated_Type (Ctyp)))) + and then Needs_Construction + (Directly_Designated_Type (Ctyp))) then return; end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a0a550d..086ef91 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1906,6 +1906,9 @@ package body Exp_Attr is function Get_Integer_Type (Typ : Entity_Id) return Entity_Id; -- Return a small integer type appropriate for the enumeration type + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id; + -- For non-scalar types return the first subtype of Typ. + procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id); -- Rewrites an attribute for Read, Write, Output, or Put_Image with a -- call to the appropriate TSS procedure. Pname is the entity for the @@ -2066,6 +2069,19 @@ package body Exp_Attr is return Small_Integer_Type_For (Siz, Uns => Is_Unsigned_Type (Typ)); end Get_Integer_Type; + -------------------------------- + -- Get_Array_Stream_Item_Type -- + -------------------------------- + + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id is + First_Sub_Typ : constant Entity_Id := First_Subtype (Typ); + begin + if Is_Private_Type (First_Sub_Typ) then + return Typ; + end if; + return First_Sub_Typ; + end Get_Array_Stream_Item_Type; + --------------------------------- -- Rewrite_Attribute_Proc_Call -- --------------------------------- @@ -4482,6 +4498,7 @@ package body Exp_Attr is P_Type : constant Entity_Id := Entity (Pref); B_Type : constant Entity_Id := Base_Type (P_Type); U_Type : constant Entity_Id := Underlying_Type (P_Type); + I_Type : Entity_Id := P_Type; Strm : constant Node_Id := First (Exprs); Fname : Entity_Id; Decl : Node_Id; @@ -4633,8 +4650,9 @@ package body Exp_Attr is new Build_And_Insert_Type_Attr_Subp (Build_Array_Input_Function); begin + I_Type := Get_Array_Stream_Item_Type (U_Type); Build_And_Insert_Array_Input_Func - (Typ => Full_Base (U_Type), + (Typ => I_Type, Decl => Decl, Subp => Fname, Attr_Ref => N); @@ -4784,8 +4802,13 @@ package body Exp_Attr is Relocate_Node (Strm))); Set_Controlling_Argument (Call, Cntrl); - Rewrite (N, Unchecked_Convert_To (P_Type, Call)); - Analyze_And_Resolve (N, P_Type); + if Is_Private_Type (P_Type) or else Is_Class_Wide_Type (P_Type) then + Rewrite (N, Unchecked_Convert_To (P_Type, Call)); + Analyze_And_Resolve (N, P_Type); + else + Rewrite (N, Call); + Analyze_And_Resolve (N, I_Type); + end if; if Nkind (Parent (N)) = N_Object_Declaration then Freeze_Stream_Subprogram (Fname); @@ -5142,7 +5165,8 @@ package body Exp_Attr is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Result_Id, Loc), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Typ)))); + Direct_Attribute_Definition_Name + (Typ, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -5818,7 +5842,7 @@ package body Exp_Attr is (Build_Array_Output_Procedure); begin Build_And_Insert_Array_Output_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -6280,7 +6304,7 @@ package body Exp_Attr is /= RTU_Entity (Interfaces_C)) then Rewrite (N, Build_String_Put_Image_Call (N)); - Analyze (N); + Analyze (N, Suppress => All_Checks); return; elsif Is_Array_Type (U_Type) then @@ -6295,10 +6319,10 @@ package body Exp_Attr is begin Build_And_Insert_Array_Put_Image_Proc - (Typ => U_Type, + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, - Subp => Pname, - Attr_Ref => N); + Subp => Pname, + Attr_Ref => N); end; Cached_Attribute_Ops.Put_Image_Map.Set (U_Type, Pname); @@ -6746,7 +6770,7 @@ package body Exp_Attr is (Build_Array_Read_Procedure); begin Build_And_Insert_Array_Read_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -8461,7 +8485,7 @@ package body Exp_Attr is (Build_Array_Write_Procedure); begin Build_And_Insert_Array_Write_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -8577,6 +8601,7 @@ package body Exp_Attr is | Attribute_Bit_Order | Attribute_Class | Attribute_Compiler_Version + | Attribute_Constructor | Attribute_Default_Bit_Order | Attribute_Default_Scalar_Storage_Order | Attribute_Definite diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index ee6010a7..a6b1718 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1031,7 +1031,7 @@ package body Exp_Ch11 is -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level) -- entity must also be either Library_Level or hoisted. It turns out -- that this would be incompatible with the current treatment of an - -- object which is local to a subprogram, subject to an Export pragma, + -- object that is local to a subprogram, subject to an Export pragma, -- not subject to an address clause, and whose declaration contains -- references to other local (non-hoisted) objects (e.g., in the initial -- value expression). @@ -1558,7 +1558,7 @@ package body Exp_Ch11 is Build_Location_String (Buf, Loc); -- If the exception is a renaming, use the exception that it - -- renames (which might be a predefined exception, e.g.). + -- renames (which might be a predefined exception). if Present (Renamed_Entity (Id)) then Id := Renamed_Entity (Id); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 60224c1..db41ab7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -3185,8 +3185,8 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); - elsif Present (Constructor_Name (Rec_Type)) then - if Present (Default_Constructor (Rec_Type)) then + elsif Needs_Construction (Rec_Type) then + if Has_Default_Constructor (Rec_Type) then -- The 'Make attribute reference (with no arguments) will -- generate a call to the one-parameter constructor procedure. @@ -3810,8 +3810,8 @@ package body Exp_Ch3 is -- Expand components with constructors to have the 'Make -- attribute. - elsif Present (Constructor_Name (Typ)) - and then Present (Default_Constructor (Typ)) + elsif Needs_Construction (Typ) + and then Has_Default_Constructor (Typ) then Set_Expression (Decl, Make_Attribute_Reference (Loc, @@ -4560,7 +4560,7 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing). - -- 10. The type has a specified Constructor aspect. + -- 10. The type needs construction with constructors. -- Note: the reason we exclude the CPP_Class case is because in this -- case the initialization is performed by the C++ constructors, and @@ -4577,7 +4577,7 @@ package body Exp_Ch3 is or else Is_Tagged_Type (Rec_Id) or else Is_Concurrent_Record_Type (Rec_Id) or else Has_Task (Rec_Id) - or else Present (Constructor_Name (Rec_Id)) + or else Needs_Construction (Rec_Id) then return True; end if; @@ -7587,8 +7587,8 @@ package body Exp_Ch3 is if No (Expr) and then Constant_Present (N) - and then (No (Constructor_Name (Typ)) - or else No (Default_Constructor (Typ))) + and then (not Needs_Construction (Typ) + or else not Has_Default_Constructor (Typ)) then return; end if; @@ -7619,8 +7619,8 @@ package body Exp_Ch3 is if Comes_From_Source (N) and then No (Expr) - and then Present (Constructor_Name (Typ)) - and then Present (Default_Constructor (Typ)) + and then Needs_Construction (Typ) + and then Has_Default_Constructor (Typ) then Expr := Make_Attribute_Reference (Loc, Attribute_Name => Name_Make, @@ -8286,6 +8286,16 @@ package body Exp_Ch3 is Set_Must_Not_Freeze (Id_Ref); Set_Assignment_OK (Id_Ref); + -- Avoid separating an object declaration from + -- its representation clauses. + + while Present (Next (Init_After)) + and then Nkind (Next (Init_After)) in + N_Attribute_Definition_Clause + loop + Init_After := Next (Init_After); + end loop; + Insert_Actions_After (Init_After, Build_Initialization_Call (N, Id_Ref, Typ, Constructor_Ref => Expr)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8fba1c4..5971db3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1432,46 +1432,48 @@ package body Exp_Ch4 is -- For (a <= b) we convert to not (a > b) - if Chars (N) = Name_Op_Le then - Rewrite (N, - Make_Op_Not (Loc, - Right_Opnd => - Make_Op_Gt (Loc, - Left_Opnd => Op1, - Right_Opnd => Op2))); - Analyze_And_Resolve (N, Standard_Boolean); - return; + case Nkind (N) is + when N_Op_Le => + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; - -- For < the Boolean expression is - -- greater__nn (op2, op1) + -- For < the Boolean expression is + -- greater__nn (op2, op1) - elsif Chars (N) = Name_Op_Lt then - Func_Body := Make_Array_Comparison_Op (Typ1, N); + when N_Op_Lt => + Func_Body := Make_Array_Comparison_Op (Typ1, N); - -- Switch operands + -- Switch operands - Op1 := Right_Opnd (N); - Op2 := Left_Opnd (N); + Op1 := Right_Opnd (N); + Op2 := Left_Opnd (N); - -- For (a >= b) we convert to not (a < b) + -- For (a >= b) we convert to not (a < b) - elsif Chars (N) = Name_Op_Ge then - Rewrite (N, - Make_Op_Not (Loc, - Right_Opnd => - Make_Op_Lt (Loc, - Left_Opnd => Op1, - Right_Opnd => Op2))); - Analyze_And_Resolve (N, Standard_Boolean); - return; + when N_Op_Ge => + Rewrite (N, + Make_Op_Not (Loc, + Right_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => Op1, + Right_Opnd => Op2))); + Analyze_And_Resolve (N, Standard_Boolean); + return; - -- For > the Boolean expression is - -- greater__nn (op1, op2) + -- For > the Boolean expression is + -- greater__nn (op1, op2) - else - pragma Assert (Chars (N) = Name_Op_Gt); - Func_Body := Make_Array_Comparison_Op (Typ1, N); - end if; + when N_Op_Gt => + Func_Body := Make_Array_Comparison_Op (Typ1, N); + + when others => raise Program_Error; + end case; Func_Name := Defining_Unit_Name (Specification (Func_Body)); Expr := @@ -4496,7 +4498,7 @@ package body Exp_Ch4 is -- Here we set no initialization on types with constructors since we -- generate initialization for the separately. - if Present (Constructor_Name (Directly_Designated_Type (PtrT))) + if Needs_Construction (Directly_Designated_Type (PtrT)) and then Nkind (Expression (N)) = N_Identifier then Set_No_Initialization (N, False); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d48b8f2..d209ab0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6250,9 +6250,9 @@ package body Exp_Ch6 is procedure Prepend_Constructor_Procedure_Prologue (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id); -- If N is the body of a constructor procedure (that is, a procedure - -- named in a Constructor aspect specification for the type of the - -- procedure's first parameter), then prepend and analyze the - -- associated initialization code for that parameter. + -- named T'Constructor where T is the type of the procedure's first + -- parameter), then prepend and analyze the associated initialization + -- code for that parameter. -- This has nothing to do with CPP constructors. ---------------- @@ -6339,16 +6339,10 @@ package body Exp_Ch6 is function First_Param_Type return Entity_Id is (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); - Is_Constructor_Procedure : constant Boolean := - Nkind (Specification (N)) = N_Procedure_Specification - and then Present (First_Formal (Spec_Id)) - and then Present (Constructor_Name (First_Param_Type)) - and then Chars (Spec_Id) = Chars (Constructor_Name - (First_Param_Type)) - and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter - and then Scope (Spec_Id) = Scope (First_Param_Type); begin - if not Is_Constructor_Procedure then + if not (Nkind (Specification (N)) = N_Procedure_Specification + and then Is_Constructor_Procedure (Spec_Id)) + then return; -- the usual case end if; @@ -6539,7 +6533,8 @@ package body Exp_Ch6 is Attribute_Name => Name_Super), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Parent_Type)))); + Direct_Attribute_Definition_Name + (Parent_Type, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -9096,27 +9091,6 @@ package body Exp_Ch6 is -- tagged, the called function itself must perform the allocation of -- the return object, so we pass parameters indicating that. - -- But that's also the case when the result subtype needs finalization - -- actions because the caller side allocation may result in undesirable - -- finalization. Consider the following example: - -- - -- function Make_Lim_Ctrl return Lim_Ctrl is - -- begin - -- return Result : Lim_Ctrl := raise Program_Error do - -- null; - -- end return; - -- end Make_Lim_Ctrl; - -- - -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); - -- - -- Even though the size of limited controlled type Lim_Ctrl is known, - -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's - -- finalization collection. The subsequent call to Make_Lim_Ctrl will - -- fail during the initialization actions for Result, which means that - -- Result (and Obj by extension) should not be finalized. However Obj - -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope - -- since it is already attached on the its finalization collection. - if Needs_BIP_Alloc_Form (Function_Id) then Temp_Init := Empty; @@ -9281,11 +9255,7 @@ package body Exp_Ch6 is end if; end; - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. + -- Add implicit actuals for the BIP formal parameters, if any Add_Unconstrained_Actuals_To_Build_In_Place_Call (Func_Call, @@ -9310,6 +9280,14 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Return_Obj_Actual); + -- If the allocation is done in the caller, create a custom Allocate + -- procedure if need be. + + if not Needs_BIP_Alloc_Form (Function_Id) then + Build_Allocate_Deallocate_Proc + (Declaration_Node (Return_Obj_Access), Mark => Allocator); + end if; + -- Finally, replace the allocator node with a reference to the temp Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); @@ -9771,7 +9749,7 @@ package body Exp_Ch6 is -- ensure that the heap allocation can properly chain the object -- and later finalize it when the library unit goes out of scope. - if Needs_BIP_Collection (Func_Call) then + if Needs_BIP_Collection (Function_Id) then Build_Finalization_Collection (Typ => Ptr_Typ, For_Lib_Level => True, @@ -10334,6 +10312,12 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin + -- No need for BIP_Collection if allocation is always done in the caller + + if not Needs_BIP_Alloc_Form (Func_Id) then + return False; + end if; + -- A formal for the finalization collection is needed for build-in-place -- functions whose result type needs finalization or is a tagged type. -- Tagged primitive build-in-place functions need such a formal because @@ -10358,12 +10342,6 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- See Make_Build_In_Place_Call_In_Allocator for the rationale - - if Needs_BIP_Collection (Func_Id) then - return True; - end if; - -- A formal giving the allocation method is needed for build-in-place -- functions whose result type is returned on the secondary stack or -- is a tagged type. Tagged primitive build-in-place functions need diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 5919627..3867270 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -301,10 +301,8 @@ package Exp_Ch6 is -- BIP_Alloc_Form parameter (see type BIP_Formal_Kind). function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Return True if the result subtype of function - -- Func_Id might need finalization actions. This includes build-in-place - -- functions with tagged result types, since they can be invoked via - -- dispatching calls, and descendant types may require finalization. + -- Ada 2005 (AI-318-02): Return True if the function needs an implicit + -- BIP_Collection parameter (see type BIP_Formal_Kind). function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean; -- Return True if the function returns an object of a type that has tasks. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 62e9d2c..600d333 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4758,18 +4758,18 @@ package body Exp_Ch7 is -- We mark the secondary stack if it is used in this construct, and -- we're not returning a function result on the secondary stack, except - -- that a build-in-place function that might or might not return on the - -- secondary stack always needs a mark. A run-time test is required in - -- the case where the build-in-place function has a BIP_Alloc extra - -- parameter (see Create_Finalizer). + -- that a build-in-place function that only conditionally returns on + -- the secondary stack will also need a mark. A run-time test for doing + -- the release call is needed in the case where the build-in-place + -- function has a BIP_Alloc_Form parameter (see Create_Finalizer). Needs_Sec_Stack_Mark : constant Boolean := - (Uses_Sec_Stack (Scop) - and then - not Sec_Stack_Needed_For_Return (Scop)) - or else - (Is_Build_In_Place_Function (Scop) - and then Needs_BIP_Alloc_Form (Scop)); + Uses_Sec_Stack (Scop) + and then + (not Sec_Stack_Needed_For_Return (Scop) + or else + (Is_Build_In_Place_Function (Scop) + and then Needs_BIP_Alloc_Form (Scop))); Needs_Custom_Cleanup : constant Boolean := Nkind (N) = N_Block_Statement @@ -9244,7 +9244,7 @@ package body Exp_Ch7 is procedure Unnest_Loop (Loop_Stmt : Node_Id) is - procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id); + procedure Fixup_Inner_Scopes (N : Node_Id); -- This procedure fixes the scope for 2 identified cases of incorrect -- scope information. -- @@ -9271,6 +9271,9 @@ package body Exp_Ch7 is -- leaves the Tree in an incoherent state (i.e. the inner procedure must -- have its enclosing procedure in its scope ancestries). + -- The same issue exists for freeze nodes with associated TSS: the node + -- is moved but the TSS procedures are not correctly nested. + -- 2) The second case happens when an object declaration is created -- within a loop used to initialize the 'others' components of an -- aggregate that is nested within a transient scope. When the transient @@ -9298,40 +9301,62 @@ package body Exp_Ch7 is -- an actual entity set). But unfortunately this proved harder to -- implement ??? - procedure Fixup_Inner_Scopes (Loop_Or_Block : Node_Id) is - Stmt : Node_Id; - Loop_Or_Block_Ent : Entity_Id; - Ent_To_Fix : Entity_Id; - Decl : Node_Id := Empty; + procedure Fixup_Inner_Scopes (N : Node_Id) is + Stmt : Node_Id := Empty; + Ent : Entity_Id; + Ent_To_Fix : Entity_Id; + Decl : Node_Id := Empty; + Elmt : Elmt_Id := No_Elmt; begin - pragma Assert (Nkind (Loop_Or_Block) in - N_Loop_Statement | N_Block_Statement); - - Loop_Or_Block_Ent := Entity (Identifier (Loop_Or_Block)); - if Nkind (Loop_Or_Block) = N_Loop_Statement then - Stmt := First (Statements (Loop_Or_Block)); - else -- N_Block_Statement - Stmt := First - (Statements (Handled_Statement_Sequence (Loop_Or_Block))); - Decl := First (Declarations (Loop_Or_Block)); + pragma + Assert + (Nkind (N) + in N_Loop_Statement | N_Block_Statement | N_Freeze_Entity); + + if Nkind (N) = N_Freeze_Entity then + Ent := Scope (Entity (N)); + else + Ent := Entity (Identifier (N)); end if; + case Nkind (N) is + when N_Loop_Statement => + Stmt := First (Statements (N)); + + when N_Block_Statement => + Stmt := First (Statements (Handled_Statement_Sequence (N))); + Decl := First (Declarations (N)); + + when N_Freeze_Entity => + if Present (TSS_Elist (N)) then + Elmt := First_Elmt (TSS_Elist (N)); + while Present (Elmt) loop + Ent_To_Fix := Node (Elmt); + Set_Scope (Ent_To_Fix, Ent); + Next_Elmt (Elmt); + end loop; + end if; + + when others => + pragma Assert (False); + end case; + -- Fix scopes for any object declaration found in the block while Present (Decl) loop if Nkind (Decl) = N_Object_Declaration then Ent_To_Fix := Defining_Identifier (Decl); - Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent); + Set_Scope (Ent_To_Fix, Ent); end if; Next (Decl); end loop; while Present (Stmt) loop - if Nkind (Stmt) = N_Block_Statement - and then Is_Abort_Block (Stmt) + if Nkind (Stmt) = N_Block_Statement and then Is_Abort_Block (Stmt) then Ent_To_Fix := Entity (Identifier (Stmt)); - Set_Scope (Ent_To_Fix, Loop_Or_Block_Ent); - elsif Nkind (Stmt) in N_Block_Statement | N_Loop_Statement + Set_Scope (Ent_To_Fix, Ent); + elsif Nkind (Stmt) + in N_Block_Statement | N_Loop_Statement | N_Freeze_Entity then Fixup_Inner_Scopes (Stmt); end if; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 1a64888..0786c40 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -193,6 +193,25 @@ package Exp_Dbug is -- extra__messages__Oeq__2 ---------------------------------- + -- Direct Attribute Definitions -- + ---------------------------------- + + -- Direct attribute definitions are subprogram declarations where the + -- subprogram name is an attribute reference, eg.: + -- procedure T'Constructor (Self... + -- defines a constructor. The above rules applied to direct attribute + -- definitions would result in names with quotation marks, which are + -- typically hard to deal with down the chain. To avoid this problem, + -- names of such definitions are encoded with as: + + -- 'D' Prefix_Name '_' Attribute_Name "_Att" + + -- For instance, the constructor above is encoded as Dt_constructor_Att. + + -- Note that, attribute reference with multiple attributes are not + -- supported yet ??? + + ---------------------------------- -- Resolving Other Name Clashes -- ---------------------------------- diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 3bb6966..f933a2e 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -501,6 +501,14 @@ package body Exp_Strm is then return Prims (RE_I_LF, RE_W_LF); + elsif Is_IEEE_Extended_Precision (U_Type) then + -- For 80-bit IEEE extended precision values, we use a special + -- write routine that sets the unused bytes to zero. The reason + -- why we don't set Stream_Size to 80 and stream only the + -- meaningful bits is that the user is allowed to select the XDR + -- implementation of streaming at bind time, and XDR does not + -- allow 80 bits floating point values. + return Prims (RE_I_LLF, RE_W_80IEEE); elsif P_Size = Standard_Long_Long_Float_Size then return Prims (RE_I_LLF, RE_W_LLF); else diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 58f6689..9a1ed70 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -220,6 +220,8 @@ package body Exp_Unst is else Lev := Lev + 1; S := Enclosing_Subprogram (S); + + pragma Assert (Present (S)); end if; end loop; end Get_Level; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4d88626..e2d2554 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7317,6 +7317,134 @@ package body Exp_Util is Loc : constant Source_Ptr := Sloc (Var); Ent : constant Entity_Id := Entity (Var); + procedure Find_In_Enclosing_Context + (Stmt : Node_Id; Current, Previous : in out Node_Id); + -- Locate an object reference inside a composite statement Stmt. On + -- entry, Previous and Current should be an object reference and its + -- parent, respectively. When search is successful, Current is Stmt and + -- Previous is its child node, so the caller can determine in which part + -- of the statement the original reference was. When search fails, both + -- Current and Previous are Empty. + + function Is_Transient_Action (N : Node_Id) return Boolean; + -- Returns True for nodes that belong to a transient action and so they + -- have no parent, because they have not been inserted to the tree yet. + + ------------------------------- + -- Find_In_Enclosing_Context -- + ------------------------------- + + procedure Find_In_Enclosing_Context + (Stmt : Node_Id; Current, Previous : in out Node_Id) + is + begin + loop + -- If we fall off the top of the tree, then that's odd, but + -- perhaps it could occur in some error situation, and the safest + -- response is simply to assume that the outcome of the condition + -- is unknown. No point in bombing during an attempt to optimize + -- things. + + if No (Current) then + + -- In particular, we expect to miss the enclosing conditional + -- statement for: + -- * references within a freezing action (because their + -- location is unrelated to the conditional statement), + -- * validity checks (becuase for references inside the + -- condition they are inserted before the conditional + -- statement itself), + -- * source locations before and after the conditionaal + -- statement. + + pragma Assert + (Inside_Freezing_Actions > 0 + or else + (Ekind (Entity (Var)) = E_Variable + and then Present (Validated_Object (Entity (Var)))) + or else + Loc < Sloc (Stmt) + or else + Loc >= Sloc (Stmt) + Text_Ptr (UI_To_Int (End_Span (Stmt))) + or else + Serious_Errors_Detected > 0); + + return; + + -- We found the enclosing conditional statement + + elsif Current = Stmt then + return; + + -- For itype declarations follow their associated node + + elsif Nkind (Current) = N_Subtype_Declaration + and then Is_Itype (Defining_Identifier (Current)) + then + Previous := Current; + Current := + Associated_Node_For_Itype (Defining_Identifier (Previous)); + + -- If associated node has not been set yet, we can use the + -- related expression, which is set earlier. + -- ??? this should be investigated + + if No (Current) then + Current := + Related_Expression (Defining_Identifier (Previous)); + end if; + pragma Assert (Present (Current)); + + -- Same for itypes that have no declaration + + elsif Nkind (Current) = N_Defining_Identifier + and then Is_Itype (Current) + then + pragma Assert (No (Parent (Current))); + Previous := Current; + Current := Associated_Node_For_Itype (Previous); + + -- For transient actions follow where they will be inserted + + elsif Is_Transient_Action (Current) then + Previous := Current; + Current := + Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; + + -- Otherwise, continue climbing + + else + Previous := Current; + Current := Parent (Current); + end if; + end loop; + end Find_In_Enclosing_Context; + + ------------------------- + -- Is_Transient_Action -- + ------------------------- + + function Is_Transient_Action (N : Node_Id) return Boolean is + begin + if Scope_Stack.Last >= Scope_Stack.First + and then Scope_Is_Transient + and then Is_List_Member (N) + then + declare + Transient_Actions : Scope_Actions renames + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped; + begin + for Action_Kind in Scope_Actions'Range loop + if List_Containing (N) = Transient_Actions (Action_Kind) then + return True; + end if; + end loop; + end; + end if; + + return False; + end Is_Transient_Action; + procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean); -- N is an expression which holds either True (S = True) or False (S = -- False) in the condition. This procedure digs out the expression and @@ -7490,156 +7618,71 @@ package body Exp_Util is declare CV : constant Node_Id := Current_Value (Ent); Sens : Boolean; - Stm : Node_Id; begin - -- If statement. Condition is known true in THEN section, known False - -- in any ELSIF or ELSE part, and unknown outside the IF statement. - - if Nkind (CV) = N_If_Statement then + -- For IF statement the condition is known true in THEN section, + -- known False in any ELSIF or ELSE part, and unknown outside the + -- IF statement. - -- Before start of IF statement - - if Loc < Sloc (CV) then - return; - - -- In condition of IF statement - - elsif In_Subtree (N => Var, Root => Condition (CV)) then - return; + if Nkind (CV) in N_If_Statement | N_Elsif_Part then - -- After end of IF statement - - elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then - return; - end if; - - -- At this stage we know that we are within the IF statement, but - -- unfortunately, the tree does not record the SLOC of the ELSE so - -- we cannot use a simple SLOC comparison to distinguish between - -- the then/else statements, so we have to climb the tree. + -- At this stage we know that we are within the conditional + -- statement, but we have to climb the tree to know in which + -- part, e.g. in THEN or ELSE statements of an IF statement. declare - N : Node_Id; - - begin - N := Parent (Var); - while Parent (N) /= CV loop - N := Parent (N); + If_Stmt : constant Node_Id := + (if Nkind (CV) = N_If_Statement + then CV + else Parent (CV)); - -- If we fall off the top of the tree, then that's odd, but - -- perhaps it could occur in some error situation, and the - -- safest response is simply to assume that the outcome of - -- the condition is unknown. No point in bombing during an - -- attempt to optimize things. + Previous : Node_Id := Var; + Current : Node_Id := Parent (Var); - if No (N) then - return; - end if; - end loop; - - -- Now we have N pointing to a node whose parent is the IF - -- statement in question, so now we can tell if we are within - -- the THEN statements. - - if Is_List_Member (N) - and then List_Containing (N) = Then_Statements (CV) - then - Sens := True; - - -- If the variable reference does not come from source, we - -- cannot reliably tell whether it appears in the else part. - -- In particular, if it appears in generated code for a node - -- that requires finalization, it may be attached to a list - -- that has not been yet inserted into the code. For now, - -- treat it as unknown. + begin + -- An ELSIF part whose condition is false could have been + -- already rewritten into NULL statement and we are already + -- past the statements inside that ELSIF part. - elsif not Comes_From_Source (N) then + if Nkind (If_Stmt) /= N_If_Statement then + pragma Assert + (Nkind (CV) = N_Elsif_Part + and then Is_Rewrite_Substitution (If_Stmt)); return; - - -- Otherwise we must be in ELSIF or ELSE part - - else - Sens := False; end if; - end; - -- ELSIF part. Condition is known true within the referenced - -- ELSIF, known False in any subsequent ELSIF or ELSE part, - -- and unknown before the ELSE part or after the IF statement. - - elsif Nkind (CV) = N_Elsif_Part then - - -- if the Elsif_Part had condition_actions, the elsif has been - -- rewritten as a nested if, and the original elsif_part is - -- detached from the tree, so there is no way to obtain useful - -- information on the current value of the variable. - -- Can this be improved ??? - - if No (Parent (CV)) then - return; - end if; - - Stm := Parent (CV); - - -- If the tree has been otherwise rewritten there is nothing - -- else to be done either. - - if Nkind (Stm) /= N_If_Statement then - return; - end if; - - -- Before start of ELSIF part - - if Loc < Sloc (CV) then - return; + Find_In_Enclosing_Context (If_Stmt, Current, Previous); - -- In condition of ELSIF part - - elsif In_Subtree (N => Var, Root => Condition (CV)) then - return; - - -- After end of IF statement + -- Check whether the reference is in the IF, THEN or ELSE/ELSIF + -- part. - elsif Loc >= Sloc (Stm) + - Text_Ptr (UI_To_Int (End_Span (Stm))) - then - return; - end if; + if Current = If_Stmt then - -- Again we lack the SLOC of the ELSE, so we need to climb the - -- tree to see if we are within the ELSIF part in question. + -- Ignore references from within the IF condition itself - declare - N : Node_Id; + if Previous = Condition (If_Stmt) then + return; - begin - N := Parent (Var); - while Parent (N) /= Stm loop - N := Parent (N); + -- Guard against if-statements coming from if-statements + -- with broken chain of parents. - -- If we fall off the top of the tree, then that's odd, but - -- perhaps it could occur in some error situation, and the - -- safest response is simply to assume that the outcome of - -- the condition is unknown. No point in bombing during an - -- attempt to optimize things. + elsif Is_List_Member (Previous) then + pragma Assert ( + List_Containing (Previous) + in Then_Statements (If_Stmt) + | Elsif_Parts (If_Stmt) + | Else_Statements (If_Stmt)); - if No (N) then + Sens := + (if CV = If_Stmt + then List_Containing (Previous) = Then_Statements (CV) + else Previous = CV); + else + pragma Assert (From_Conditional_Expression (If_Stmt)); return; end if; - end loop; - - -- Now we have N pointing to a node whose parent is the IF - -- statement in question, so see if is the ELSIF part we want. - -- the THEN statements. - - if N = CV then - Sens := True; - - -- Otherwise we must be in subsequent ELSIF or ELSE part - else - Sens := False; + return; end if; end; @@ -7650,26 +7693,31 @@ package body Exp_Util is declare Loop_Stmt : constant Node_Id := Parent (CV); + Previous : Node_Id := Var; + Current : Node_Id := Parent (Var); + begin - -- Before start of body of loop + pragma Assert (Nkind (Loop_Stmt) = N_Loop_Statement); - if Loc < Sloc (Loop_Stmt) then - return; + Find_In_Enclosing_Context (Loop_Stmt, Current, Previous); - -- In condition of while loop + -- Check whether the reference is inside the WHILE loop - elsif In_Subtree (N => Var, Root => Condition (CV)) then - return; + if Current = Loop_Stmt then - -- After end of LOOP statement + -- Ignore references from within the WHILE condition itself - elsif Loc >= Sloc (End_Label (Loop_Stmt)) then - return; + if Previous = Iteration_Scheme (Loop_Stmt) then + return; - -- We are within the body of the loop + else + pragma Assert + (List_Containing (Previous) = Statements (Loop_Stmt)); + Sens := True; + end if; else - Sens := True; + return; end if; end; diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index 6022d3b..c914c55 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -134,19 +134,6 @@ package body Fname is Renamings_Included : Boolean := True) return Boolean is begin - -- Definitely false if longer than 12 characters (8.3), except for the - -- Interfaces packages and also the implementation units of the 128-bit - -- types under System. - - if Fname'Length > 12 - and then Fname (Fname'First .. Fname'First + 1) /= "i-" - and then Fname (Fname'First .. Fname'First + 1) /= "s-" - and then not Has_Prefix (Fname, "system-") - and then not Has_Prefix (Fname, "interfac__") - then - return False; - end if; - if not Has_Internal_Extension (Fname) then return False; end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d8fdc30..66145e5 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8382,7 +8382,8 @@ package body Freeze is -- and Per-Object Expressions" will suppress the insertion, and the -- freeze node will be dropped on the floor. - if Saved_Ghost_Config.Ghost_Mode = Ignore + if not CodePeer_Mode + and then Saved_Ghost_Config.Ghost_Mode = Ignore and then Ghost_Config.Ghost_Mode /= Ignore and then Present (Ghost_Config.Ignored_Ghost_Region) then diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 6cd1355..d25006c 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -131,7 +131,6 @@ package Gen_IL.Fields is Corresponding_Stub, Dcheck_Function, Declarations, - Default_Expression, Default_Storage_Pool, Default_Name, Default_Subtype_Mark, @@ -153,7 +152,6 @@ package Gen_IL.Fields is Do_Length_Check, Do_Overflow_Check, Do_Range_Check, - Do_Storage_Check, Elaborate_All_Desirable, Elaborate_All_Present, Elaborate_Desirable, @@ -161,7 +159,6 @@ package Gen_IL.Fields is Else_Actions, Else_Statements, Elsif_Parts, - Enclosing_Variant, End_Label, End_Span, Entity_Or_Associated_Node, @@ -204,7 +201,6 @@ package Gen_IL.Fields is Generic_Parent, Generic_Parent_Type, Handled_Statement_Sequence, - Handler_List_Entry, Has_Created_Identifier, Has_Dereference_Action, Has_Dynamic_Length_Check, @@ -283,7 +279,6 @@ package Gen_IL.Fields is Is_Static_Coextension, Is_Static_Expression, Is_Structural, - Is_Subprogram_Descriptor, Is_Task_Allocation_Block, Is_Task_Body_Procedure, Is_Task_Master, @@ -376,7 +371,6 @@ package Gen_IL.Fields is Reason, Record_Extension_Part, Redundant_Use, - Renaming_Exception, Result_Definition, Return_Object_Declarations, Return_Statement_Entity, @@ -480,8 +474,6 @@ package Gen_IL.Fields is Component_Clause, Component_Size, Component_Type, - Constructor_List, - Constructor_Name, Continue_Mark, Contract, Contract_Wrapper, @@ -614,7 +606,6 @@ package Gen_IL.Fields is Has_Own_Invariants, Has_Partial_Visible_Refinement, Has_Per_Object_Constraint, - Has_Pragma_Controlled, Has_Pragma_Elaborate_Body, Has_Pragma_Inline, Has_Pragma_Inline_Always, @@ -808,7 +799,6 @@ package Gen_IL.Fields is Is_Unchecked_Union, Is_Underlying_Full_View, Is_Underlying_Record_View, - Is_Unimplemented, Is_Unsigned_Type, Is_Uplevel_Referenced_Entity, Is_Valued_Procedure, @@ -818,6 +808,7 @@ package Gen_IL.Fields is Is_Volatile_Object, Is_Volatile_Full_Access, Is_Wrapper, + Is_IEEE_Extended_Precision, Itype_Printed, Kill_Elaboration_Checks, Known_To_Have_Preelab_Init, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index bd091cb..d3ac63a 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -203,7 +203,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Unchecked_Union, Flag, Impl_Base_Type_Only), Sm (Is_Underlying_Full_View, Flag), Sm (Is_Underlying_Record_View, Flag, Base_Type_Only), - Sm (Is_Unimplemented, Flag), Sm (Is_Uplevel_Referenced_Entity, Flag), Sm (Is_Visible_Formal, Flag), Sm (Is_Visible_Lib_Unit, Flag), @@ -456,8 +455,6 @@ begin -- Gen_IL.Gen.Gen_Entities Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"), Sm (Class_Wide_Equivalent_Type, Node_Id), Sm (Class_Wide_Type, Node_Id), - Sm (Constructor_List, Elist_Id), - Sm (Constructor_Name, Node_Id), Sm (Contract, Node_Id), Sm (Current_Use_Clause, Node_Id), Sm (Derived_Type_Link, Node_Id), @@ -630,7 +627,8 @@ begin -- Gen_IL.Gen.Gen_Entities -- first named subtype). Ab (Float_Kind, Real_Kind, - (Sm (Digits_Value, Upos))); + (Sm (Digits_Value, Upos), + Sm (Is_IEEE_Extended_Precision, Flag))); Cc (E_Floating_Point_Type, Float_Kind); -- Floating point type, used for the anonymous base type of the @@ -646,7 +644,6 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Associated_Storage_Pool, Node_Id, Root_Type_Only), Sm (Directly_Designated_Type, Node_Id), Sm (Finalization_Collection, Node_Id, Root_Type_Only), - Sm (Has_Pragma_Controlled, Flag, Impl_Base_Type_Only), Sm (Has_Storage_Size_Clause, Flag, Impl_Base_Type_Only), Sm (Is_Access_Constant, Flag), Sm (Is_Local_Anonymous_Access, Flag), diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 9ce2511..e6e00ff 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -192,14 +192,24 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Char_Literal_Value, Unat))); Ab (N_Op, N_Has_Entity, - (Sm (Chars, Name_Id), - Sm (Do_Overflow_Check, Flag), + (Sm (Do_Overflow_Check, Flag), Sm (Has_Private_View, Flag), Sm (Has_Secondary_Private_View, Flag))); Ab (N_Binary_Op, N_Op, (Sy (Left_Opnd, Node_Id), - Sy (Right_Opnd, Node_Id))); + Sy (Right_Opnd, Node_Id), + Sy (Chars, Name_Id, Default_No_Name))); + -- N_Binary_Op and N_Unary_Op do not strictly need Chars, since the value + -- is fully determined by the Nkind. However, for example, Errout refers to + -- Chars without knowing statically whether the Nkind is in N_Op. + -- In any case, we don't inherit Chars from N_Op, because we want it to + -- come after the other syntactic fields, so that positional notation can + -- be used in calls to Make_Op_Add and friends. + -- + -- Make_Op_Add and friends will now have a Chars parameter. Callers + -- should always use the default, because the Chars field is set + -- properly as a special case (see Gen_IL.Gen). Cc (N_Op_Add, N_Binary_Op); @@ -259,7 +269,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Op_Shift_Right_Arithmetic, N_Op_Shift); Ab (N_Unary_Op, N_Op, - (Sy (Right_Opnd, Node_Id))); + (Sy (Right_Opnd, Node_Id), + Sy (Chars, Name_Id, Default_No_Name))); Cc (N_Op_Abs, N_Unary_Op); Cc (N_Op_Minus, N_Unary_Op); @@ -290,7 +301,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Ab (N_Short_Circuit, N_Subexpr, (Sy (Left_Opnd, Node_Id), Sy (Right_Opnd, Node_Id), - Sm (Actions, List_Id))); + Sy (Actions, List_Id, Default_No_List))); Cc (N_And_Then, N_Short_Circuit); Cc (N_Or_Else, N_Short_Circuit); @@ -403,7 +414,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Null_Exclusion_Present, Flag, Default_False), Sy (Expression, Node_Id, Default_Empty), Sm (For_Special_Return_Object, Flag), - Sm (Do_Storage_Check, Flag), Sm (Is_Dynamic_Coextension, Flag), Sm (Is_Static_Coextension, Flag), Sm (No_Initialization, Flag), @@ -515,7 +525,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Null_Exclusion_Present, Flag, Default_False), Sy (Access_Definition, Node_Id, Default_Empty), Sy (Subtype_Mark, Node_Id, Default_Empty), - Sy (Default_Expression, Node_Id, Default_Empty), + Sy (Expression, Node_Id, Default_Empty), Sy (Aspect_Specifications, List_Id, Default_No_List), Sm (More_Ids, Flag), Sm (Prev_Ids, Flag))); @@ -568,8 +578,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Assignment_OK, Flag), Sm (Corresponding_Generic_Association, Node_Id), Sm (Exception_Junk, Flag), - Sm (Handler_List_Entry, Node_Id), - Sm (Is_Subprogram_Descriptor, Flag), Sm (More_Ids, Flag), Sm (No_Initialization, Flag), Sm (Prev_Ids, Flag), @@ -730,7 +738,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Activation_Chain_Entity, Node_Id), Sm (Acts_As_Spec, Flag), Sm (Corresponding_Entry_Body, Node_Id), - Sm (Do_Storage_Check, Flag), Sm (Has_Relative_Deadline_Pragma, Flag), Sm (Is_Entry_Barrier_Function, Flag), Sm (Is_Protected_Subprogram_Body, Flag), @@ -1154,9 +1161,9 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Target, Node_Id))); Cc (N_Case_Expression_Alternative, Node_Kind, - (Sm (Actions, List_Id), - Sy (Discrete_Choices, List_Id), + (Sy (Discrete_Choices, List_Id), Sy (Expression, Node_Id, Default_Empty), + Sy (Actions, List_Id, Default_No_List), Sm (Has_SP_Choice, Flag))); Cc (N_Case_Statement_Alternative, Node_Kind, @@ -1283,10 +1290,9 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Exception_Declaration, N_Declaration, (Sy (Defining_Identifier, Node_Id), Sy (Aspect_Specifications, List_Id, Default_No_List), - Sm (Expression, Node_Id), + Sy (Expression, Node_Id, Default_Empty), Sm (More_Ids, Flag), - Sm (Prev_Ids, Flag), - Sm (Renaming_Exception, Node_Id))); + Sm (Prev_Ids, Flag))); Cc (N_Exception_Handler, Node_Kind, (Sy (Choice_Parameter, Node_Id, Default_Empty), @@ -1426,7 +1432,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Parameter_Type, Node_Id), Sy (Expression, Node_Id, Default_Empty), Sy (Aspect_Specifications, List_Id, Default_No_List), - Sm (Default_Expression, Node_Id), Sm (More_Ids, Flag), Sm (Prev_Ids, Flag))); @@ -1531,7 +1536,6 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Discrete_Choices, List_Id), Sy (Component_List, Node_Id), Sm (Dcheck_Function, Node_Id), - Sm (Enclosing_Variant, Node_Id), Sm (Has_SP_Choice, Flag), Sm (Present_Expr, Uint))); diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 5eb1a58..873c3cd 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -167,7 +167,6 @@ package body Gen_IL.Gen is -- Check that syntactic fields precede semantic fields. Note that this -- check is happening before we compute inherited fields. - -- Exempt Chars and Actions from this rule, for now. declare Semantic_Seen : Boolean := False; @@ -178,11 +177,8 @@ package body Gen_IL.Gen is raise Illegal with "syntactic fields must precede semantic ones " & Image (T); end if; - else - if Fields (J).F not in Chars | Actions then - Semantic_Seen := True; - end if; + Semantic_Seen := True; end if; end loop; end; @@ -509,14 +505,11 @@ package body Gen_IL.Gen is Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set; Setter_Needs_Parent : Field_Set := - (Actions | Expression | Then_Actions | Else_Actions => True, + (Then_Actions | Else_Actions => True, others => False); -- Set of fields where the setter should set the Parent. True for - -- syntactic fields of type Node_Id and List_Id, but with some - -- exceptions. Expression is syntactic AND semantic, and the Parent - -- is needed. Default_Expression is also both, but the Parent is not - -- needed. Then_Actions and Else_Actions are not syntactic, but the - -- Parent is needed. + -- syntactic fields of type Node_Id and List_Id. Then_Actions and + -- Else_Actions are not syntactic, but the Parent is needed. -- -- Computed in Check_For_Syntactic_Field_Mismatch. @@ -896,7 +889,7 @@ package body Gen_IL.Gen is -- For example, Left_Opnd comes before Right_Opnd, -- which wouldn't be the case if Right_Opnd were -- inherited from N_Op. - ((T = N_Op and then F = Right_Opnd) + ((T = N_Op and then F in Right_Opnd | Chars) or else (T = N_Renaming_Declaration and then F = Name) or else (T = N_Generic_Renaming_Declaration and then F = Name) or else F in Defining_Unit_Name @@ -1301,26 +1294,15 @@ package body Gen_IL.Gen is end if; end loop; - -- The following fields violate this rule. We might want to - -- simplify by getting rid of these cases, but we allow them - -- for now. At least, we don't want to add any new cases of - -- syntactic/semantic mismatch. + if Syntactic_Seen and Semantic_Seen then + raise Illegal with + "syntactic/semantic mismatch for " & Image (F); + end if; - if F in Chars | Actions | Expression | Default_Expression + if Field_Table (F).Field_Type in Traversed_Field_Type + and then Syntactic_Seen then - pragma Assert (Syntactic_Seen and Semantic_Seen); - - else - if Syntactic_Seen and Semantic_Seen then - raise Illegal with - "syntactic/semantic mismatch for " & Image (F); - end if; - - if Field_Table (F).Field_Type in Traversed_Field_Type - and then Syntactic_Seen - then - Setter_Needs_Parent (F) := True; - end if; + Setter_Needs_Parent (F) := True; end if; end; end if; @@ -2675,7 +2657,7 @@ package body Gen_IL.Gen is if Is_Descendant (N_Op, T) then -- Special cases for N_Op nodes: fill in the Chars and Entity - -- fields even though they were not passed in. + -- fields. Assert that the Chars passed in is defaulted. declare Op : constant String := Image_Sans_N (T); @@ -2705,6 +2687,7 @@ package body Gen_IL.Gen is -- "Op_", but the Name_Id constant does not. begin + Put (S, "pragma Assert (Chars = No_Name);" & LF); Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF); Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF); end; @@ -2990,7 +2973,7 @@ package body Gen_IL.Gen is (if T in Entity_Type and then F in Node_Field then " -- N" else ""); -- A comment to put out for fields of entities that are - -- shared with nodes, such as Chars. + -- shared with nodes. begin while First_Bit < Type_Bit_Size_Aligned (T) loop diff --git a/gcc/ada/gen_il-gen.ads b/gcc/ada/gen_il-gen.ads index cb364ad..149afe1 100644 --- a/gcc/ada/gen_il-gen.ads +++ b/gcc/ada/gen_il-gen.ads @@ -48,14 +48,12 @@ -- If a field is syntactic, then the constructors in Nmake take a parameter to -- initialize that field. In addition, the tree-traversal routines in Atree -- (Traverse_Func and Traverse_Proc) traverse syntactic fields that are of --- type Node_Id (or subtypes of Node_Id) or List_Id. Finally, (with some --- exceptions documented in the body) the setter for a syntactic node or list --- field "Set_F (N, Val)" will set the Parent of Val to N, unless Val is Empty --- or Error[_List]. +-- type Node_Id (or subtypes of Node_Id) or List_Id. Finally, the setter for a +-- syntactic node or list field "Set_F (N, Val)" will set the Parent of Val to +-- N, unless Val is Empty or Error[_List]. -- --- Note that the same field can be syntactic in some node types but semantic --- in other node types. This is an added complexity that we might want to --- eliminate someday. We shouldn't add any new such cases. +-- No syntactic/semantic mixing: the same field cannot be syntactic in some +-- node types but semantic in other node types. -- -- A "program" written in the Gen_IL.Gen language consists of calls to the -- "Create_..." routines below, followed by a call to Compile, also below. In diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index 77685f2..bd2d480 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -311,6 +311,8 @@ package body Gen_IL.Internals is return "Is_Elaboration_Warnings_OK_Id"; when Is_Elaboration_Warnings_OK_Node => return "Is_Elaboration_Warnings_OK_Node"; + when Is_IEEE_Extended_Precision => + return "Is_IEEE_Extended_Precision"; when Is_Known_Guaranteed_ABE => return "Is_Known_Guaranteed_ABE"; when Is_RACW_Stub_Type => diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index e7a55ef..d49d94d 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -740,6 +740,14 @@ package body Ghost is then return True; + -- It is always legal to use a ghost prefix. More complex + -- scenarios are analyzed for the selector. + + elsif Nkind (Par) = N_Selected_Component + and then Prefix (Par) = Prev + then + return True; + elsif Is_OK_Declaration (Par) then return True; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 68a3c14..23c9977 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Oct 17, 2025 +GNAT Reference Manual , Oct 31, 2025 AdaCore @@ -20724,8 +20724,7 @@ machines with strict alignment requirements, GNAT checks (at compile time if possible, generating a warning, or at execution time with a run-time check) that the alignment is appropriate. If the run-time check fails, then @code{Program_Error} is raised. This run-time -check is suppressed if range checks are suppressed, or if the special GNAT -check Alignment_Check is suppressed, or if +check is suppressed if the GNAT check Alignment_Check is suppressed, or if @code{pragma Restrictions (No_Elaboration_Code)} is in effect. It is also suppressed by default on non-strict alignment machines (such as the x86). diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 86b2cbc..4789757 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Oct 06, 2025 +GNAT User's Guide for Native Platforms , Oct 31, 2025 AdaCore @@ -30333,8 +30333,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{d2}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 9e60fa8..a966c28 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3380,15 +3380,6 @@ package body Inline is -- be performed in a separate pass, using an instantiation of the -- previous subprogram over aspect specifications reachable from N. - function Process_Sloc (Nod : Node_Id) return Traverse_Result; - -- If the call being expanded is that of an internal subprogram, set the - -- sloc of the generated block to that of the call itself, so that the - -- expansion is skipped by the "next" command in gdb. Same processing - -- for a subprogram in a predefined file, e.g. Ada.Tags. If - -- Debug_Generated_Code is true, suppress this change to simplify our - -- own development. Same in GNATprove mode, to ensure that warnings and - -- diagnostics point to the proper location. - procedure Reset_Dispatching_Calls (N : Node_Id); -- In subtree N search for occurrences of dispatching calls that use the -- Ada 2005 Object.Operation notation and the object is a formal of the @@ -3647,22 +3638,6 @@ package body Inline is procedure Replace_Formals_In_Aspects is new Traverse_Proc (Process_Formals_In_Aspects); - ------------------ - -- Process_Sloc -- - ------------------ - - function Process_Sloc (Nod : Node_Id) return Traverse_Result is - begin - if not Debug_Generated_Code then - Set_Sloc (Nod, Sloc (N)); - Set_Comes_From_Source (Nod, False); - end if; - - return OK; - end Process_Sloc; - - procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); - ------------------------------ -- Reset_Dispatching_Calls -- ------------------------------ @@ -4176,13 +4151,6 @@ package body Inline is Replace_Formals_In_Aspects (Blk); Set_Parent (Blk, N); - if GNATprove_Mode then - null; - - elsif not Comes_From_Source (Subp) or else Is_Predef then - Reset_Slocs (Blk); - end if; - if Is_Unc_Decl then -- No action needed since return statement has been already removed diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb index 9d9d21d..bd6b135 100644 --- a/gcc/ada/libgnat/a-cbmutr.adb +++ b/gcc/ada/libgnat/a-cbmutr.adb @@ -2357,11 +2357,11 @@ is end Rec; begin - if First_Child (Root (V)) = No_Element then + if Is_Empty (V) then Array_Before (S); Array_After (S); else - Rec (First_Child (Root (V))); + Rec (Root (V)); end if; end Put_Image; diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb index b84eb16..0c6d338 100644 --- a/gcc/ada/libgnat/a-cimutr.adb +++ b/gcc/ada/libgnat/a-cimutr.adb @@ -1910,11 +1910,11 @@ is end Rec; begin - if First_Child (Root (V)) = No_Element then + if Is_Empty (V) then Array_Before (S); Array_After (S); else - Rec (First_Child (Root (V))); + Rec (Root (V)); end if; end Put_Image; diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb index df3741b..2d6393d 100644 --- a/gcc/ada/libgnat/a-comutr.adb +++ b/gcc/ada/libgnat/a-comutr.adb @@ -1844,11 +1844,11 @@ is end Rec; begin - if First_Child (Root (V)) = No_Element then + if Is_Empty (V) then Array_Before (S); Array_After (S); else - Rec (First_Child (Root (V))); + Rec (Root (V)); end if; end Put_Image; diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 1e97a47..713aad4 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1912,11 +1912,12 @@ package body System.Dwarf_Lines is ------------------------ procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : STE.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : out Boolean; - Res : in out System.Bounded_Strings.Bounded_String) + (Cin : Dwarf_Context; + Traceback : STE.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Symbol_Found : out Boolean; + Res : in out System.Bounded_Strings.Bounded_String) is use Ada.Characters.Handling; C : Dwarf_Context := Cin; @@ -1953,7 +1954,7 @@ package body System.Dwarf_Lines is -- If we're not requested to suppress hex addresses, emit it now. - if not Suppress_Hex then + if not Suppress_Hex and then not Subprg_Name_Only then Append_Address (Res, Addr_In_Traceback); Append (Res, ' '); end if; @@ -2006,10 +2007,12 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - Append (Res, " at "); - Append (Res, String (File_Name (1 .. Last))); - Append (Res, ':'); - Append (Res, Line_Image (2 .. Line_Image'Last)); + if not Subprg_Name_Only then + Append (Res, " at "); + Append (Res, String (File_Name (1 .. Last))); + Append (Res, ':'); + Append (Res, Line_Image (2 .. Line_Image'Last)); + end if; end; else if Subprg_Name.Len > 0 then @@ -2020,7 +2023,9 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - Append (Res, " at ???"); + if not Subprg_Name_Only then + Append (Res, " at ???"); + end if; end if; Append (Res, ASCII.LF); diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads index c65d66e..641e515 100644 --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -80,11 +80,12 @@ package System.Dwarf_Lines is -- Read symbol information to speed up Symbolic_Traceback. procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : STE.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : out Boolean; - Res : in out System.Bounded_Strings.Bounded_String); + (Cin : Dwarf_Context; + Traceback : STE.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Symbol_Found : out Boolean; + Res : in out System.Bounded_Strings.Bounded_String); -- Generate a string for a traceback suitable for displaying to the user. -- If one or more symbols are found, Symbol_Found is set to True. This -- allows the caller to fall back to hexadecimal addresses. diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb index 844c530..9315ae1 100644 --- a/gcc/ada/libgnat/s-stratt.adb +++ b/gcc/ada/libgnat/s-stratt.adb @@ -1036,4 +1036,21 @@ package body System.Stream_Attributes is Ada.Streams.Write (Stream.all, From_WWC (Item)); end W_WWC; + procedure W_80IEEE (Stream : not null access RST; Item : Long_Long_Float) is + begin + if XDR_Support then + XDR.W_LLF (Stream, Item); + return; + end if; + + declare + X : S_LLF := From_LLF (Item); + + N_IEEE_Extended_Precision_Bytes : constant := 10; + begin + X (N_IEEE_Extended_Precision_Bytes + 1 .. X'Last) := (others => 0); + Ada.Streams.Write (Stream.all, X); + end; + end W_80IEEE; + end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads index 87f1357..9f27f5a 100644 --- a/gcc/ada/libgnat/s-stratt.ads +++ b/gcc/ada/libgnat/s-stratt.ads @@ -171,6 +171,8 @@ package System.Stream_Attributes is procedure W_WC (Stream : not null access RST; Item : Wide_Character); procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); + procedure W_80IEEE (Stream : not null access RST; Item : Long_Long_Float); + function Block_IO_OK return Boolean; -- Indicate whether the current setting supports block IO. See -- System.Strings.Stream_Ops (s-ststop) for details on block IO. diff --git a/gcc/ada/libgnat/s-stratt__cheri.adb b/gcc/ada/libgnat/s-stratt__cheri.adb index aefb8b3..9e336f3 100644 --- a/gcc/ada/libgnat/s-stratt__cheri.adb +++ b/gcc/ada/libgnat/s-stratt__cheri.adb @@ -1016,4 +1016,21 @@ package body System.Stream_Attributes is Ada.Streams.Write (Stream.all, From_WWC (Item)); end W_WWC; + procedure W_80IEEE (Stream : not null access RST; Item : Long_Long_Float) is + begin + if XDR_Support then + XDR.W_LLF (Stream, Item); + return; + end if; + + declare + X : S_LLF := From_LLF (Item); + + N_IEEE_Extended_Precision_Bytes : constant := 10; + begin + X (N_IEEE_Extended_Precision_Bytes + 1 .. X'Last) := (others => 0); + Ada.Streams.Write (Stream.all, X); + end; + end W_80IEEE; + end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb index 96a1925..5bab088 100644 --- a/gcc/ada/libgnat/s-trasym.adb +++ b/gcc/ada/libgnat/s-trasym.adb @@ -123,4 +123,8 @@ package body System.Traceback.Symbolic is null; end Enable_Cache; + function Calling_Entity return String is + begin + return "???"; + end Calling_Entity; end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads index 96b26cb..59939ce 100644 --- a/gcc/ada/libgnat/s-trasym.ads +++ b/gcc/ada/libgnat/s-trasym.ads @@ -105,4 +105,7 @@ package System.Traceback.Symbolic is -- with default value), but backward compatibility for direct calls -- is supported. + function Calling_Entity return String; + -- Return the name of the caller of the current subprogram if it's + -- available. Otherwise return "???". end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 479b5d3..09026c9 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -96,13 +96,16 @@ package body System.Traceback.Symbolic is -- Initialize Exec_Module if not already initialized function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array; - Suppress_Hex : Boolean) return String; + (Traceback : System.Traceback_Entries.Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean) return String; function Symbolic_Traceback (E : Ada.Exceptions.Exception_Occurrence; Suppress_Hex : Boolean) return String; -- Suppress_Hex means do not print any hexadecimal addresses, even if the - -- symbol is not available. + -- symbol is not available. Subprg_Name_Only means to only print the + -- subprogram name for each frame, as opposed to the complete description + -- of the frame. function Lt (Left, Right : Module_Cache_Acc) return Boolean; -- Sort function for Module_Cache @@ -166,30 +169,34 @@ package body System.Traceback.Symbolic is -- Non-symbolic traceback (simply write addresses in hexa) procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Like the public Symbolic_Traceback_No_Lock except there is no provision - -- against concurrent accesses. + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); + -- Like the public Symbolic_Traceback except there is no provision against + -- concurrent accesses. procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Returns the Traceback for a given module procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Build string containing symbolic traceback for the given call chain procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String); -- Likewise but using Module Max_String_Length : constant := 4096; @@ -328,6 +335,36 @@ package body System.Traceback.Symbolic is Module_Cache_Array_Sort (Modules_Cache.all); end Enable_Cache; + function Calling_Entity return String is + N_Skipped_Frames : constant Natural := 3; + -- We ask Call_Chain to skip the following frames: + -- + -- 1. The frame of Call_Chain itself. + -- 2. The frame of Calling_Entity. + -- 3. The frame of Calling_Entity's caller. + -- + -- The frame above that is the function the caller is looking for. + + Traceback : Tracebacks_Array (1 .. 1); + Len : Natural; + begin + Call_Chain (Traceback, 1, Len, Skip_Frames => N_Skipped_Frames); + + if Len = 0 then + return "???"; + end if; + + declare + With_Trailing_Newline : constant String := + Symbolic_Traceback + (Traceback, Suppress_Hex => True, Subprg_Name_Only => True); + begin + return + With_Trailing_Newline + (With_Trailing_Newline'First .. With_Trailing_Newline'Last - 1); + end; + end Calling_Entity; + --------------------- -- Executable_Name -- --------------------- @@ -450,14 +487,15 @@ package body System.Traceback.Symbolic is ------------------------------- procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is Success : Boolean; begin - if Symbolic.Module_Name.Is_Supported then + if Symbolic.Module_Name.Is_Supported and then not Subprg_Name_Only then Append (Res, '['); Append (Res, Module.Name.all); Append (Res, ']' & ASCII.LF); @@ -467,11 +505,13 @@ package body System.Traceback.Symbolic is (Module.C, Traceback, Suppress_Hex, + Subprg_Name_Only, Success, Res); if not Success then - Hexa_Traceback (Traceback, Suppress_Hex, Res); + Hexa_Traceback + (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); end if; -- We must not allow an unhandled exception here, since this function @@ -487,9 +527,10 @@ package body System.Traceback.Symbolic is ------------------------------------- procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is F : constant Natural := Traceback'First; begin @@ -514,6 +555,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback, Modules_Cache (Mid).all, + Subprg_Name_Only, Suppress_Hex, Res); return; @@ -527,6 +569,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end; else @@ -534,10 +577,7 @@ package body System.Traceback.Symbolic is -- First try the executable if Is_Inside (Exec_Module.C, Traceback (F)) then Multi_Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); + (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); return; end if; @@ -553,10 +593,7 @@ package body System.Traceback.Symbolic is Init_Module (Module, Success, M_Name, Load_Addr); if Success then Multi_Module_Symbolic_Traceback - (Traceback, - Module, - Suppress_Hex, - Res); + (Traceback, Module, Suppress_Hex, Subprg_Name_Only, Res); Close_Module (Module); else -- Module not found @@ -564,6 +601,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end if; end; @@ -571,10 +609,11 @@ package body System.Traceback.Symbolic is end Multi_Module_Symbolic_Traceback; procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is Pos : Positive; begin @@ -599,10 +638,12 @@ package body System.Traceback.Symbolic is (Traceback (Traceback'First .. Pos - 1), Module, Suppress_Hex, + Subprg_Name_Only, Res); Multi_Module_Symbolic_Traceback (Traceback (Pos .. Traceback'Last), Suppress_Hex, + Subprg_Name_Only, Res); end Multi_Module_Symbolic_Traceback; @@ -633,23 +674,22 @@ package body System.Traceback.Symbolic is -------------------------------- procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean; + Res : in out Bounded_String) is begin if Symbolic.Module_Name.Is_Supported then - Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback, Suppress_Hex, Subprg_Name_Only, Res); else if Exec_Module_State = Failed then Append (Res, "Call stack traceback locations:" & ASCII.LF); - Hexa_Traceback (Traceback, Suppress_Hex, Res); + Hexa_Traceback + (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); else Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); + (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); end if; end if; end Symbolic_Traceback_No_Lock; @@ -662,8 +702,9 @@ package body System.Traceback.Symbolic is -- Copied from Ada.Exceptions.Exception_Data function Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean) return String + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Subprg_Name_Only : Boolean) return String is Load_Address : constant Address := Get_Executable_Load_Address; Res : Bounded_String (Max_Length => Max_String_Length); @@ -671,12 +712,13 @@ package body System.Traceback.Symbolic is begin System.Soft_Links.Lock_Task.all; Init_Exec_Module; - if Load_Address /= Null_Address then + if not Subprg_Name_Only and then Load_Address /= Null_Address then Append (Res, LDAD_Header); Append_Address (Res, Load_Address); Append (Res, ASCII.LF); end if; - Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); + Symbolic_Traceback_No_Lock + (Traceback, Suppress_Hex, Subprg_Name_Only, Res); System.Soft_Links.Unlock_Task.all; return To_String (Res); @@ -690,13 +732,17 @@ package body System.Traceback.Symbolic is function Symbolic_Traceback (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is begin - return Symbolic_Traceback (Traceback, Suppress_Hex => False); + return + Symbolic_Traceback + (Traceback, Suppress_Hex => False, Subprg_Name_Only => False); end Symbolic_Traceback; function Symbolic_Traceback_No_Hex (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is begin - return Symbolic_Traceback (Traceback, Suppress_Hex => True); + return + Symbolic_Traceback + (Traceback, Suppress_Hex => True, Subprg_Name_Only => False); end Symbolic_Traceback_No_Hex; function Symbolic_Traceback @@ -704,9 +750,11 @@ package body System.Traceback.Symbolic is Suppress_Hex : Boolean) return String is begin - return Symbolic_Traceback + return + Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E), - Suppress_Hex); + Suppress_Hex, + False); end Symbolic_Traceback; function Symbolic_Traceback diff --git a/gcc/ada/locales.c b/gcc/ada/locales.c index a3f884c..89c5b7b 100644 --- a/gcc/ada/locales.c +++ b/gcc/ada/locales.c @@ -646,7 +646,7 @@ str_get_last_byte (char *lc_all) { return last_byte; } -/* Utility function to search in the iso_639_1 table for an iso-639-1 code; +/* Utility function to search in the iso_639 table for an iso-639-1 code; returns the corresponding iso-639-3 code or NULL if not found. */ static char* @@ -670,7 +670,30 @@ iso_639_1_to_639_3(char* iso_639_1_code) { return NULL; } -/* Utility function to search in the iso_639_1 table for a language name; +/* Utility function to search in the iso_639 table for an iso-639-3 code; + returns 1 if found or 0 if not found. */ + +static int +is_iso_639_3(char* iso_639_3_code) { + int len = ARRAY_SIZE (iso_639); + char **p = iso_639; + int j; + + p = p + 1; + for (j=0; j < len/3; j++) { + char* s1 = iso_639_3_code; + char* s2 = *p; + + if (s1[0]==s2[0] && s1[1]==s2[1] && s1[2]==s2[2]) + return 1; + + p = p + 3; + } + + return 0; +} + +/* Utility function to search in the iso_639 table for a language name; returns the corresponding iso-639-3 code or NULL if not found. */ static char* @@ -772,7 +795,8 @@ c_get_language_code (char4 p) { /* Copy the ISO-639-3 code (adding a null terminator) */ } else if (lang_length == 3) { - str_copy(iso_639_3_code, lc_all, lang_length); + if (is_iso_639_3(lc_all)) + str_copy(iso_639_3_code, lc_all, lang_length); /* Handle conversion of language name to ISO-639-3 */ diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 7bd449d..18cd907 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -466,7 +466,7 @@ package body Ch12 is end if; No_Constraint; - Set_Default_Expression (Decl_Node, Init_Expr_Opt); + Set_Expression (Decl_Node, Init_Expr_Opt); P_Aspect_Specifications (Decl_Node, Semicolon => True); if Ident > 1 then diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index dbb894f..00b780b 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -632,6 +632,77 @@ package body Ch13 is return Aspects; end Get_Aspect_Specifications; + ----------------------------- + -- P_Attribute_Designators -- + ----------------------------- + + function P_Attribute_Designators (Initial_Prefix : Node_Id) return Node_Id + is + Accumulator : Node_Id := Initial_Prefix; + Designator : Name_Id; + begin + while Token = Tok_Apostrophe loop + + Scan; -- past apostrophe + + Designator := No_Name; + + if Token = Tok_Identifier then + Designator := Token_Name; + + -- Note that the parser must complain in case of an internal + -- attribute name that comes from source since internal names are + -- meant to be used only by the compiler. + + if not Is_Attribute_Name (Designator) + and then (not Is_Internal_Attribute_Name (Designator) + or else Comes_From_Source (Token_Node)) + then + Signal_Bad_Attribute; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Designator := Name_Delta; + + elsif Token = Tok_Digits then + Designator := Name_Digits; + + elsif Token = Tok_Access then + Designator := Name_Access; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- Here we have an OK attribute scanned, and the corresponding + -- Attribute identifier node is stored in Designator. + + declare + Temp : constant Node_Id := Accumulator; + begin + Accumulator := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Set_Prefix (Accumulator, Temp); + end; + Set_Attribute_Name (Accumulator, Designator); + Scan; + end loop; + + return Accumulator; + end P_Attribute_Designators; + -------------------------------------------- -- 13.1 Representation Clause (also I.7) -- -------------------------------------------- @@ -674,8 +745,6 @@ package body Ch13 is function P_Representation_Clause return Node_Id is For_Loc : Source_Ptr; Name_Node : Node_Id; - Prefix_Node : Node_Id; - Attr_Name : Name_Id; Identifier_Node : Node_Id; Rep_Clause_Node : Node_Id; Expr_Node : Node_Id; @@ -693,8 +762,7 @@ package body Ch13 is -- Check case of qualified name to give good error message if Token = Tok_Dot then - Error_Msg_SC - ("representation clause requires simple name!"); + Error_Msg_SC ("representation clause requires simple name!"); loop exit when Token /= Tok_Dot; @@ -706,80 +774,28 @@ package body Ch13 is -- Attribute Definition Clause if Token = Tok_Apostrophe then + Name_Node := P_Attribute_Designators (Identifier_Node); - -- Allow local names of the form a'b'.... This enables - -- us to parse class-wide streams attributes correctly. - - Name_Node := Identifier_Node; - while Token = Tok_Apostrophe loop - - Scan; -- past apostrophe - - Identifier_Node := Token_Node; - Attr_Name := No_Name; - - if Token = Tok_Identifier then - Attr_Name := Token_Name; - - -- Note that the parser must complain in case of an internal - -- attribute name that comes from source since internal names - -- are meant to be used only by the compiler. - - if not Is_Attribute_Name (Attr_Name) - and then (not Is_Internal_Attribute_Name (Attr_Name) - or else Comes_From_Source (Token_Node)) - then - Signal_Bad_Attribute; - end if; - - if Style_Check then - Style.Check_Attribute_Name (False); - end if; - - -- Here for case of attribute designator is not an identifier - - else - if Token = Tok_Delta then - Attr_Name := Name_Delta; - - elsif Token = Tok_Digits then - Attr_Name := Name_Digits; + -- Check for Address clause which needs to be marked for use in + -- optimizing performance of Exp_Util.Following_Address_Clause. - elsif Token = Tok_Access then - Attr_Name := Name_Access; - - else - Error_Msg_AP ("attribute designator expected"); - raise Error_Resync; - end if; - - if Style_Check then - Style.Check_Attribute_Name (True); - end if; - end if; - - -- Here we have an OK attribute scanned, and the corresponding - -- Attribute identifier node is stored in Ident_Node. - - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); - Set_Prefix (Name_Node, Prefix_Node); - Set_Attribute_Name (Name_Node, Attr_Name); - Scan; - - -- Check for Address clause which needs to be marked for use in - -- optimizing performance of Exp_Util.Following_Address_Clause. + declare + Cursor : Node_Id := Name_Node; + begin + while Nkind (Prefix (Cursor)) = N_Attribute_Reference loop + Cursor := Prefix (Cursor); + end loop; - if Attr_Name = Name_Address - and then Nkind (Prefix_Node) = N_Identifier + if Attribute_Name (Cursor) = Name_Address + and then Nkind (Prefix (Cursor)) = N_Identifier then - Set_Name_Table_Boolean1 (Chars (Prefix_Node), True); + Set_Name_Table_Boolean1 (Chars (Prefix (Cursor)), True); end if; - end loop; + end; Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc); - Set_Name (Rep_Clause_Node, Prefix_Node); - Set_Chars (Rep_Clause_Node, Attr_Name); + Set_Name (Rep_Clause_Node, Prefix (Name_Node)); + Set_Chars (Rep_Clause_Node, Attribute_Name (Name_Node)); T_Use; Expr_Node := P_Expression_No_Right_Paren; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index a6418a5..2be3670 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -128,7 +128,8 @@ package body Ch6 is -- This routine scans out a subprogram declaration, subprogram body, -- subprogram renaming declaration or subprogram generic instantiation. - -- It also handles the new Ada 2012 expression function form + -- It also handles the new Ada 2012 expression function form, and the GNAT + -- extension for direct attribute definition. -- SUBPROGRAM_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION @@ -141,6 +142,9 @@ package body Ch6 is -- SUBPROGRAM_SPECIFICATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + -- | procedure LOCAL_NAME'ATTRIBUTE_DESIGNATOR PARAMETER_PROFILE + -- | function LOCAL_NAME'ATTRIBUTE_DESIGNATOR + -- PARAMETER_AND_RESULT_PROFILE -- PARAMETER_PROFILE ::= [FORMAL_PART] @@ -190,6 +194,13 @@ package body Ch6 is function Contains_Import_Aspect (Aspects : List_Id) return Boolean; -- Return True if Aspects contains an Import aspect. + procedure Rewrite_Entity_If_Direct_Attribute_Def + (Name : Node_Id; Spec : Node_Id); + -- In case of direct attribute definitions this procedure rewrites the + -- defining unit name of the specification node with a new entity. It is + -- essential to maintain the information that the original node comes + -- from a direct attribute definition. + ---------------------------- -- Contains_Import_Aspect -- ---------------------------- @@ -208,6 +219,39 @@ package body Ch6 is return False; end Contains_Import_Aspect; + -------------------------------------------- + -- Rewrite_Entity_If_Direct_Attribute_Def -- + -------------------------------------------- + + procedure Rewrite_Entity_If_Direct_Attribute_Def + (Name : Node_Id; Spec : Node_Id) + is + New_Entity, Copy_Spec : Node_Id; + begin + if Nkind (Name) = N_Attribute_Reference + and then Is_Direct_Attribute_Definition_Name (Attribute_Name (Name)) + then + -- Note that, this workaround is needed to retain the info that + -- the current subprogram comes from a direct attribute + -- definition. Otherwise, we would need to add an entity flag + -- Is_Constructor. Currently this flag already exists and could be + -- misleading as it refer to CPP constructors ??? + + Copy_Spec := New_Copy (Spec); + + New_Entity := Make_Defining_Identifier (Sloc (Name), + Direct_Attribute_Definition_Name + (Prefix (Name), Attribute_Name (Name))); + Set_Comes_From_Source (New_Entity); + Set_Parent (New_Entity, Copy_Spec); + + Set_Defining_Unit_Name (Copy_Spec, New_Entity); + Rewrite (Spec, Copy_Spec); + end if; + end Rewrite_Entity_If_Direct_Attribute_Def; + + -- Local variables + Specification_Node : Node_Id; Name_Node : Node_Id; Aspects : List_Id; @@ -232,6 +276,8 @@ package body Ch6 is Is_Overriding : Boolean := False; Not_Overriding : Boolean := False; + -- Start of processing for P_Subprogram + begin -- Set up scope stack entry. Note that the Labl field will be set later @@ -343,11 +389,19 @@ package body Ch6 is Name_Node := P_Defining_Program_Unit_Name; end if; + -- Deal with direct attribute definition in subprogram specification + + if Token = Tok_Apostrophe then + Error_Msg_GNAT_Extension ("direct attribute definition", Token_Ptr); + + Name_Node := P_Attribute_Designators (Name_Node); + end if; + Scopes (Scope.Last).Labl := Name_Node; Ignore (Tok_Colon); -- Deal with generic instantiation, the one case in which we do not - -- have a subprogram specification as part of whatever we are parsing + -- have a subprogram specification as part of whatever we are parsing. if Token = Tok_Is then Save_Scan_State (Scan_State); -- at the IS @@ -940,6 +994,9 @@ package body Ch6 is Parse_Decls_Begin_End (Body_Node); end if; + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); + return Body_Node; end Scan_Body_Or_Expression_Function; end if; @@ -952,6 +1009,9 @@ package body Ch6 is Set_Specification (Decl_Node, Specification_Node); Aspects := Get_Aspect_Specifications (Semicolon => False); + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); + -- Aspects may be present on a subprogram body. The source parsed -- so far is that of its specification. Go parse the body and attach -- the collected aspects, if any, to the body. diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 8166705..8637e07 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -156,12 +156,12 @@ package body Endh is function Same_Label (Label1, Label2 : Node_Id) return Boolean; -- This function compares the two names associated with the given nodes. -- If they are both simple (i.e. have Chars fields), then they have to - -- be the same name. Otherwise they must both be N_Selected_Component - -- nodes, referring to the same set of names, or Label1 is an N_Designator - -- referring to the same set of names as the N_Defining_Program_Unit_Name - -- in Label2. Any other combination returns False. This routine is used - -- to compare the End_Labl scanned from the End line with the saved label - -- value in the scope stack. + -- be the same name. If they are both N_Selected_Component or + -- N_Attribute_Reference nodes, they must refer to the same set of names. + -- Otherwise, Label1 must be a N_Designator referring to the same set of + -- names as the N_Defining_Program_Unit_Name in Label2. Any other + -- combination returns False. This routine is used to compare the End_Labl + -- scanned from the End line with the saved label value in the scope stack. --------------- -- Check_End -- @@ -270,6 +270,16 @@ package body Endh is end if; End_Labl := P_Designator; + + -- Case of direct attribute definition + + if Token = Tok_Apostrophe then + Error_Msg_GNAT_Extension + ("direct attribute definition", Token_Ptr); + + End_Labl := P_Attribute_Designators (End_Labl); + end if; + End_Labl_Present := True; -- We have now scanned out a name. Here is where we do a check @@ -1359,6 +1369,12 @@ package body Endh is return Same_Label (Prefix (Label1), Prefix (Label2)) and then Same_Label (Selector_Name (Label1), Selector_Name (Label2)); + elsif Nkind (Label1) = N_Attribute_Reference + and then Nkind (Label2) = N_Attribute_Reference + then + return Same_Label (Prefix (Label1), Prefix (Label2)) and then + Attribute_Name (Label1) = Attribute_Name (Label2); + elsif Nkind (Label1) = N_Designator and then Nkind (Label2) = N_Defining_Program_Unit_Name then diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 8ced09d..6fc4bed 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1019,6 +1019,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is package Ch13 is function P_Representation_Clause return Node_Id; + function P_Attribute_Designators + (Initial_Prefix : Node_Id) return Node_Id; + -- This procedure parses trailing apostrophes and attribute designators, + -- i.e., the "'b'c..." suffix in "a'b'c...". "a" must have already been + -- parsed into Initial_Prefix and the scan pointer must be pointing + -- right past "a". If no apostrophe is found we just return + -- Initial_Prefix, otherwise the return value is a chain of + -- N_Attribute_Reference nodes, nested via the Prefix field and ending + -- with Initial_Prefix. + function Aspect_Specifications_Present (Strict : Boolean := Ada_Version < Ada_2012) return Boolean; -- This function tests whether the next keyword is WITH followed by diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index c82af11..ee529e1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1900,6 +1900,7 @@ package Rtsfind is RE_W_U24, -- System.Stream_Attributes RE_W_WC, -- System.Stream_Attributes RE_W_WWC, -- System.Stream_Attributes + RE_W_80IEEE, -- System.Stream_Attributes RE_Storage_Array_Input, -- System.Strings.Stream_Ops RE_Storage_Array_Input_Blk_IO, -- System.Strings.Stream_Ops @@ -3565,6 +3566,7 @@ package Rtsfind is RE_W_U24 => System_Stream_Attributes, RE_W_WC => System_Stream_Attributes, RE_W_WWC => System_Stream_Attributes, + RE_W_80IEEE => System_Stream_Attributes, RE_Storage_Array_Input => System_Strings_Stream_Ops, RE_Storage_Array_Input_Blk_IO => System_Strings_Stream_Ops, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e9e245a..20270c2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3957,6 +3957,13 @@ package body Sem_Attr is Error_Attr_P ("prefix of % attribute must be object of discriminated type"); + ----------------- + -- Constructor -- + ----------------- + + when Attribute_Constructor => + Error_Attr_P ("attribute% can only be used to define constructors"); + --------------- -- Copy_Sign -- --------------- @@ -5180,12 +5187,17 @@ package body Sem_Attr is Expr : Entity_Id; begin if not All_Extensions_Allowed then - Error_Msg_GNAT_Extension ("Make attribute", Loc); + Error_Msg_GNAT_Extension ("attribute %", Loc); return; end if; + Check_Type; Set_Etype (N, Etype (P)); + if not Needs_Construction (Entity (P)) then + Error_Msg_NE ("no available constructor for&", N, Entity (P)); + end if; + if Present (Expressions (N)) then Expr := First (Expressions (N)); while Present (Expr) loop @@ -5197,6 +5209,9 @@ package body Sem_Attr is Next (Expr); end loop; + + elsif not Has_Default_Constructor (Entity (P)) then + Error_Msg_NE ("no default constructor for&", N, Entity (P)); end if; end; @@ -11144,6 +11159,7 @@ package body Sem_Attr is | Attribute_Class | Attribute_Code_Address | Attribute_Compiler_Version + | Attribute_Constructor | Attribute_Count | Attribute_Default_Bit_Order | Attribute_Default_Scalar_Storage_Order @@ -12477,70 +12493,6 @@ package body Sem_Attr is Set_Address_Taken (Entity (P)); end if; - if Nkind (P) = N_Slice then - - -- Arr (X .. Y)'address is identical to Arr (X)'address, - -- even if the array is packed and the slice itself is not - -- addressable. Transform the prefix into an indexed component. - - -- Note that the transformation is safe only if we know that - -- the slice is non-null. That is because a null slice can have - -- an out of bounds index value. - - -- Right now, gigi blows up if given 'Address on a slice as a - -- result of some incorrect freeze nodes generated by the front - -- end, and this covers up that bug in one case, but the bug is - -- likely still there in the cases not handled by this code ??? - - -- It's not clear what 'Address *should* return for a null - -- slice with out of bounds indexes, this might be worth an ARG - -- discussion ??? - - -- One approach would be to do a length check unconditionally, - -- and then do the transformation below unconditionally, but - -- analyze with checks off, avoiding the problem of the out of - -- bounds index. This approach would interpret the address of - -- an out of bounds null slice as being the address where the - -- array element would be if there was one, which is probably - -- as reasonable an interpretation as any ??? - - declare - Loc : constant Source_Ptr := Sloc (P); - D : constant Node_Id := Discrete_Range (P); - Lo : Node_Id; - - begin - if Is_Entity_Name (D) - and then - Not_Null_Range - (Type_Low_Bound (Entity (D)), - Type_High_Bound (Entity (D))) - then - Lo := - Make_Attribute_Reference (Loc, - Prefix => (New_Occurrence_Of (Entity (D), Loc)), - Attribute_Name => Name_First); - - elsif Nkind (D) = N_Range - and then Not_Null_Range (Low_Bound (D), High_Bound (D)) - then - Lo := Low_Bound (D); - - else - Lo := Empty; - end if; - - if Present (Lo) then - Rewrite (P, - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Prefix (P)), - Expressions => New_List (Lo))); - - Analyze_And_Resolve (P); - end if; - end; - end if; - ------------------ -- Body_Version -- ------------------ @@ -12805,45 +12757,43 @@ package body Sem_Attr is and then Scope (Op) = Standard_Standard and then not Strict then - declare - Op_Chars : constant Any_Operator_Name := Chars (Op); - -- Nonassociative ops like division are unlikely - -- to come up in practice, but they are legal. - begin - case Op_Chars is - when Name_Op_Add - | Name_Op_Subtract - | Name_Op_Multiply - | Name_Op_Divide - | Name_Op_Expon - => - return Is_Numeric_Type (Typ); - - when Name_Op_Mod | Name_Op_Rem => - return Is_Numeric_Type (Typ) - and then Is_Discrete_Type (Typ); - - when Name_Op_And | Name_Op_Or | Name_Op_Xor => - -- No Boolean array operators in Standard - return Is_Boolean_Type (Typ) - or else Is_Modular_Integer_Type (Typ); + -- Nonassociative ops like division are unlikely to + -- come up in practice, but they are legal. + + case Any_Operator_Name'(Chars (Op)) is + when Name_Op_Add + | Name_Op_Subtract + | Name_Op_Multiply + | Name_Op_Divide + | Name_Op_Expon + => + return Is_Numeric_Type (Typ); + + when Name_Op_Mod | Name_Op_Rem => + return Is_Numeric_Type (Typ) + and then Is_Discrete_Type (Typ); + + when Name_Op_And | Name_Op_Or | Name_Op_Xor => + -- No Boolean array operators in Standard + return Is_Boolean_Type (Typ) + or else Is_Modular_Integer_Type (Typ); + + when Name_Op_Concat => + return Is_Array_Type (Typ) + and then Number_Dimensions (Typ) = 1; + + when Name_Op_Eq | Name_Op_Ne + | Name_Op_Lt | Name_Op_Le + | Name_Op_Gt | Name_Op_Ge + => + return Is_Boolean_Type (Typ); + + when Name_Op_Abs | Name_Op_Not => + -- unary ops were already handled + + raise Program_Error; + end case; - when Name_Op_Concat => - return Is_Array_Type (Typ) - and then Number_Dimensions (Typ) = 1; - - when Name_Op_Eq | Name_Op_Ne - | Name_Op_Lt | Name_Op_Le - | Name_Op_Gt | Name_Op_Ge - => - return Is_Boolean_Type (Typ); - - when Name_Op_Abs | Name_Op_Not => - -- unary ops were already handled - pragma Assert (False); - raise Program_Error; - end case; - end; else return False; end if; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 58a4beb..107e27e 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -184,9 +184,6 @@ package body Sem_Aux is -- Normal case, search enclosing scopes - -- Note: the test for Present (S) should not be required, it defends - -- against an ill-formed tree. - S := Scope (Ent); loop -- If we somehow got an empty value for Scope, the tree must be diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cbb0deb..702939a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -599,8 +599,8 @@ package body Sem_Ch12 is -- whose views can change between the point of instantiation and the point -- of instantiation of the body. In addition, mark the generic renamings -- as generic actuals, so that they are not compatible with other actuals. - -- Recurse on an actual that is a formal package whose declaration has - -- a box. + -- For an instantiation of a formal package that is declared with a box or + -- contains defaulted parameters, make the corresponding actuals visible. function Component_Type_For_Private_View (T : Entity_Id) return Entity_Id; -- Return the component type of array type T, with the following addition: @@ -944,6 +944,13 @@ package body Sem_Ch12 is -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List -- set to No_Elist. + procedure Restore_Private_Views (Pack_Id : Entity_Id; Is_Package : Boolean); + -- Restore the private views of external types, and unmark the generic + -- renamings of actuals, so that they become compatible subtypes again. + -- Reset the visibility of the actuals (some of them may have been made + -- visible by Check_Generic_Actuals). For subprograms, Pack_Id is the + -- wrapper package built to hold the renamings and Is_Package is False. + procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -958,6 +965,10 @@ package body Sem_Ch12 is -- Associate analyzed generic parameter with corresponding instance. Used -- for semantic checks at instantiation time. + procedure Switch_View (T : Entity_Id); + -- Switch the partial and full views of a type, as well as those of its + -- private dependents (i.e. its subtypes and derived types). + function True_Parent (N : Node_Id) return Node_Id; -- For a subunit, return parent of corresponding stub, else return -- parent of node. @@ -1080,18 +1091,6 @@ package body Sem_Ch12 is Table_Increment => 100, Table_Name => "Instance_Envs"); - procedure Restore_Private_Views - (Pack_Id : Entity_Id; - Is_Package : Boolean := True); - -- Restore the private views of external types, and unmark the generic - -- renamings of actuals, so that they become compatible subtypes again. - -- For subprograms, Pack_Id is the package constructed to hold the - -- renamings. - - procedure Switch_View (T : Entity_Id); - -- Switch the partial and full views of a type and its private - -- dependents (i.e. its subtypes and derived types). - ------------------------------------ -- Structures for Error Reporting -- ------------------------------------ @@ -1607,8 +1606,8 @@ package body Sem_Ch12 is return Result : Actual_Rec do case Nkind (Un_Formal) is when N_Formal_Object_Declaration => - if Present (Default_Expression (Un_Formal)) then - Result := (Name_Exp, Default_Expression (Un_Formal)); + if Present (Expression (Un_Formal)) then + Result := (Name_Exp, Expression (Un_Formal)); end if; when N_Formal_Type_Declaration => if Present (Default_Subtype_Mark (Un_Formal)) then @@ -1663,18 +1662,14 @@ package body Sem_Ch12 is if Box_Present (Src_Assoc) then Assoc.Actual := (Kind => Box_Actual); - if False then -- ??? - -- Disable this for now, because we have various - -- code that needs to be updated. - Error_Msg_N - ("box requires named notation", Src_Assoc); - end if; + Error_Msg_N ("box requires named notation", Src_Assoc); else Assoc.Actual := (Name_Exp, Explicit_Generic_Actual_Parameter (Src_Assoc)); pragma Assert (Present (Assoc.Actual.Name_Exp)); end if; + Assoc.Actual_Origin := From_Explicit_Actual; Next (Src_Assoc); @@ -2557,7 +2552,7 @@ package body Sem_Ch12 is (Defining_Identifier (Assoc.Un_Formal), Sloc (N)), Explicit_Generic_Actual_Parameter => - New_Copy_Tree (Default_Expression (Assoc.Un_Formal)))); + New_Copy_Tree (Expression (Assoc.Un_Formal)))); end if; end if; @@ -3361,7 +3356,7 @@ package body Sem_Ch12 is --------------------------------------- procedure Analyze_Formal_Object_Declaration (N : Node_Id) is - E : constant Node_Id := Default_Expression (N); + E : constant Node_Id := Expression (N); Id : constant Node_Id := Defining_Identifier (N); K : Entity_Kind; @@ -5696,7 +5691,7 @@ package body Sem_Ch12 is Check_Formal_Packages (Act_Decl_Id); Restore_Hidden_Primitives (Vis_Prims_List); - Restore_Private_Views (Act_Decl_Id); + Restore_Private_Views (Act_Decl_Id, Is_Package => True); Inherit_Context (Gen_Decl, N); @@ -7218,7 +7213,7 @@ package body Sem_Ch12 is if not Is_Intrinsic_Subprogram (Act_Decl_Id) then Inherit_Context (Gen_Decl, N); - Restore_Private_Views (Pack_Id, False); + Restore_Private_Views (Pack_Id, Is_Package => False); -- If the context requires a full instantiation, mark node for -- subsequent construction of the body. @@ -8571,9 +8566,6 @@ package body Sem_Ch12 is Set_Is_Generic_Actual_Type (Full_View (E)); end if; - Set_Is_Hidden (E, False); - Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); - -- We constructed the generic actual type as a subtype of the -- supplied type. This means that it normally would not inherit -- subtype specific attributes of the actual, which is wrong for @@ -8627,21 +8619,15 @@ package body Sem_Ch12 is (Renamed_Entity (E), Is_Formal_Box => Box_Present (Parent (Associated_Formal_Package (E)))); - - Set_Is_Hidden (E, False); end if; - - -- If this is a subprogram instance (in a wrapper package) the - -- actual is fully visible. - - elsif Is_Wrapper_Package (Instance) then - Set_Is_Hidden (E, False); + end if; -- If the formal package is declared with a box, or if the formal - -- parameter is defaulted, it is visible in the body. + -- parameter is defaulted, the actual is visible in the instance. - elsif Is_Formal_Box or else Is_Visible_Formal (E) then + if Is_Formal_Box or else Is_Visible_Formal (E) then Set_Is_Hidden (E, False); + Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); end if; -- Check directly the type of the actual objects, including the @@ -11660,8 +11646,10 @@ package body Sem_Ch12 is null; elsif Present (Associated_Formal_Package (E)) then - Check_Generic_Actuals (Renamed_Entity (E), True); - Set_Is_Hidden (E, False); + Check_Generic_Actuals + (Renamed_Entity (E), + Is_Formal_Box => + Box_Present (Parent (Associated_Formal_Package (E)))); -- Find formal package in generic unit that corresponds to -- (instance of) formal package in instance. @@ -12450,7 +12438,7 @@ package body Sem_Ch12 is (Nkind (Actual_Of_Formal) = N_Package_Instantiation); end if; - Next (Actual_Of_Formal); + Next_Non_Pragma (Actual_Of_Formal); -- A formal subprogram may be overloaded, so advance in -- the list of actuals to make sure we do not match two @@ -13223,7 +13211,7 @@ package body Sem_Ch12 is -- to capture local names that may be hidden if the generic is -- a child unit. - if Nkind (Actual) = N_Aggregate then + if Nkind (Unqualify (Actual)) = N_Aggregate then Preanalyze_And_Resolve (Actual, Typ); end if; @@ -13236,7 +13224,7 @@ package body Sem_Ch12 is end if; end; - elsif Present (Default_Expression (Formal)) then + elsif Present (Expression (Formal)) then -- Use default to construct declaration @@ -13254,7 +13242,7 @@ package body Sem_Ch12 is Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => Def, Expression => New_Copy_Tree - (Default_Expression (Formal))); + (Expression (Formal))); Copy_Ghost_Aspect (Formal, To => Decl_Node); Set_Corresponding_Generic_Association @@ -13679,7 +13667,7 @@ package body Sem_Ch12 is Set_Defining_Unit_Name (Act_Body, Act_Body_Name); Set_Corresponding_Spec (Act_Body, Act_Decl_Id); - Check_Generic_Actuals (Act_Decl_Id, False); + Check_Generic_Actuals (Act_Decl_Id, Is_Formal_Box => False); Check_Initialized_Types; -- Install primitives hidden at the point of the instantiation but @@ -13927,7 +13915,7 @@ package body Sem_Ch12 is -- the two mechanisms swap exactly the same entities, in particular -- the private entities dependent on the primary private entities. - Restore_Private_Views (Act_Decl_Id); + Restore_Private_Views (Act_Decl_Id, Is_Package => True); -- Remove the current unit from visibility if this is an instance -- that is not elaborated on the fly for inlining purposes. @@ -14174,7 +14162,7 @@ package body Sem_Ch12 is Set_Corresponding_Spec (Act_Body, Act_Decl_Id); Set_Has_Completion (Act_Decl_Id); - Check_Generic_Actuals (Pack_Id, False); + Check_Generic_Actuals (Pack_Id, Is_Formal_Box => False); -- Generate a reference to link the visible subprogram instance to -- the generic body, which for navigation purposes is the only @@ -14245,7 +14233,7 @@ package body Sem_Ch12 is Inherit_Context (Gen_Body, Inst_Node); - Restore_Private_Views (Pack_Id, False); + Restore_Private_Views (Pack_Id, Is_Package => False); if Par_Installed then Remove_Parent (In_Body => True); @@ -17093,10 +17081,18 @@ package body Sem_Ch12 is Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); begin - if No (Current_Instantiated_Parent.Act_Id) then - -- Restore environment after subprogram inlining + -- Restore environment after subprogram inlining - Restore_Private_Views (Empty); + if No (Current_Instantiated_Parent.Act_Id) then + declare + M : Elmt_Id; + begin + M := First_Elmt (Exchanged_Views); + while Present (M) loop + Exchange_Declarations (Node (M)); + Next_Elmt (M); + end loop; + end; end if; Current_Instantiated_Parent := Saved.Instantiated_Parent; @@ -17115,9 +17111,7 @@ package body Sem_Ch12 is -- Restore_Private_Views -- --------------------------- - procedure Restore_Private_Views - (Pack_Id : Entity_Id; - Is_Package : Boolean := True) + procedure Restore_Private_Views (Pack_Id : Entity_Id; Is_Package : Boolean) is M : Elmt_Id; E : Entity_Id; @@ -17136,6 +17130,7 @@ package body Sem_Ch12 is procedure Restore_Nested_Formal (Formal : Entity_Id) is pragma Assert (Ekind (Formal) = E_Package); Ent : Entity_Id; + begin if Present (Renamed_Entity (Formal)) and then Denotes_Formal_Package (Renamed_Entity (Formal), True) @@ -17198,16 +17193,13 @@ package body Sem_Ch12 is Next_Elmt (M); end loop; - if No (Pack_Id) then - return; - end if; - -- Make the generic formal parameters private, and make the formal types -- into subtypes of the actuals again. E := First_Entity (Pack_Id); while Present (E) loop - Set_Is_Hidden (E, True); + Set_Is_Hidden (E); + Set_Is_Potentially_Use_Visible (E, False); if Is_Type (E) and then Nkind (Parent (E)) = N_Subtype_Declaration @@ -17231,6 +17223,7 @@ package body Sem_Ch12 is (Entity (Subtype_Indication (Parent (E)))) then null; + else Set_Is_Generic_Actual_Type (E, False); @@ -17275,7 +17268,7 @@ package body Sem_Ch12 is -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains -- visible on exit from the instance, and therefore nothing needs - -- to be done either, except to keep it accessible. + -- to be done either. if Is_Package and then Renamed_Entity (E) = Pack_Id then exit; @@ -17286,7 +17279,7 @@ package body Sem_Ch12 is elsif Denotes_Formal_Package (Renamed_Entity (E), True, Pack_Id) then - Set_Is_Hidden (E, False); + null; else declare @@ -17301,8 +17294,8 @@ package body Sem_Ch12 is exit when Ekind (Id) = E_Package and then Renamed_Entity (Id) = Act_P; - Set_Is_Hidden (Id, True); - Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); + Set_Is_Hidden (Id); + Set_Is_Potentially_Use_Visible (Id, False); if Ekind (Id) = E_Package then Restore_Nested_Formal (Id); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f7be890..31af1bb 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -442,11 +442,6 @@ package body Sem_Ch13 is Off : Boolean; -- Whether the address is offset within Y in the second case - - Alignment_Checks_Suppressed : Boolean; - -- Whether alignment checks are suppressed by an active scope suppress - -- setting. We need to save the value in order to be able to reuse it - -- after the back end has been run. end record; package Address_Clause_Checks is new Table.Table ( @@ -457,26 +452,6 @@ package body Sem_Ch13 is Table_Increment => 200, Table_Name => "Address_Clause_Checks"); - function Alignment_Checks_Suppressed - (ACCR : Address_Clause_Check_Record) return Boolean; - -- Return whether the alignment check generated for the address clause - -- is suppressed. - - --------------------------------- - -- Alignment_Checks_Suppressed -- - --------------------------------- - - function Alignment_Checks_Suppressed - (ACCR : Address_Clause_Check_Record) return Boolean - is - begin - if Checks_May_Be_Suppressed (ACCR.X) then - return Is_Check_Suppressed (ACCR.X, Alignment_Check); - else - return ACCR.Alignment_Checks_Suppressed; - end if; - end Alignment_Checks_Suppressed; - ----------------------------------------- -- Adjust_Record_For_Reverse_Bit_Order -- ----------------------------------------- @@ -5041,16 +5016,6 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; - when Aspect_Constructor => - if not All_Extensions_Allowed then - Error_Msg_Name_1 := Nam; - Error_Msg_GNAT_Extension ("aspect %", Loc); - goto Continue; - end if; - - Set_Constructor_Name (E, Expr); - Set_Needs_Construction (E); - -- Dimension when Aspect_Dimension => @@ -7096,11 +7061,15 @@ package body Sem_Ch13 is end if; end; - -- Entity has delayed freeze, so we will generate an + -- The entity has delayed freeze, so we will generate an -- alignment check at the freeze point unless suppressed. + -- We will unconditionally generate it when the alignment + -- is specified in addition to the address, to compensate + -- for the check being suppressed by default on machines + -- that do not need strict alignment of memory accesses. - if not Range_Checks_Suppressed (U_Ent) - and then not Alignment_Checks_Suppressed (U_Ent) + if not Alignment_Checks_Suppressed (U_Ent) + or else Present (Alignment_Clause (U_Ent)) then Set_Check_Address_Alignment (N); end if; @@ -7175,6 +7144,14 @@ package body Sem_Ch13 is if Is_Array_Type (U_Ent) then Set_Alignment (Base_Type (U_Ent), Align); end if; + + -- See the Attribute_Address case above for the rationale + + if not Is_Type (U_Ent) + and then Present (Address_Clause (U_Ent)) + then + Set_Check_Address_Alignment (Address_Clause (U_Ent)); + end if; end if; end Alignment; @@ -7844,7 +7821,7 @@ package body Sem_Ch13 is end if; end if; - -- For Object'Size, set Esize only + -- For objects, set Esize only else if Is_Elementary_Type (Etyp) @@ -7858,26 +7835,37 @@ package body Sem_Ch13 is Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size); Error_Msg_N - ("size for primitive object must be a power of 2 in " - & "the range ^-^", N); - end if; + ("size for elementary object must be a power of 2 " + & "in the range ^-^", N); - Set_Esize (U_Ent, Size); - end if; + -- As per RM 13.1(25/5), only a confirming size clause + -- (i.e. Size = Type'Object_Size) for aliased objects + -- of elementary types is required to be supported. + -- We reject nonconfirming clauses for these objects. - -- As of RM 13.1, only confirming size - -- (i.e. (Size = Esize (Etyp))) for aliased object of - -- elementary type must be supported. - -- GNAT rejects nonconfirming size for such object. + elsif Is_Aliased (U_Ent) + and then Is_Elementary_Type (Etyp) + and then Size /= Esize (Etyp) + then + Error_Msg_N + ("nonconfirming Size for aliased object is not " + & "supported", N); - if Is_Aliased (U_Ent) - and then Is_Elementary_Type (Etyp) - and then Known_Esize (U_Ent) - and then Size /= Esize (Etyp) - then - Error_Msg_N - ("nonconfirming Size for aliased object is not " - & "supported", N); + -- We also reject nonconfirming clauses for (nonaliased) + -- objects of floating-point types because smaller sizes + -- would require integer operations to access the objects + -- and larger sizes would require integer operations to + -- manipulate the padding bits. + + elsif Is_Floating_Point_Type (Etyp) + and then Size /= Esize (Etyp) + then + Error_Msg_N + ("nonconfirming Size for floating-point object is " + & "not supported", N); + end if; + + Set_Esize (U_Ent, Size); end if; -- Handle extension aspect 'Size'Class which allows for @@ -11753,8 +11741,7 @@ package body Sem_Ch13 is -- name, so we need to verify that one of these interpretations is -- the one available at the freeze point. - elsif A_Id in Aspect_Constructor - | Aspect_Destructor + elsif A_Id in Aspect_Destructor | Aspect_Input | Aspect_Output | Aspect_Read @@ -12050,8 +12037,7 @@ package body Sem_Ch13 is -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Constructor - | Aspect_Input + when Aspect_Input | Aspect_Output | Aspect_Put_Image | Aspect_Read @@ -16670,9 +16656,8 @@ package body Sem_Ch13 is Y : Entity_Id; Off : Boolean) is - ACS : constant Boolean := Scope_Suppress.Suppress (Alignment_Check); begin - Address_Clause_Checks.Append ((N, X, A, Y, Off, ACS)); + Address_Clause_Checks.Append ((N, X, A, Y, Off)); end Register_Address_Clause_Check; ------------------------ @@ -17357,9 +17342,6 @@ package body Sem_Ch13 is => null; - when Aspect_Constructor => - null; - when Aspect_Dynamic_Predicate | Aspect_Ghost_Predicate | Aspect_Predicate @@ -19125,7 +19107,7 @@ package body Sem_Ch13 is -- Check for known value not multiple of alignment if No (ACCR.Y) then - if not Alignment_Checks_Suppressed (ACCR) + if Check_Address_Alignment (ACCR.N) and then X_Alignment /= 0 and then ACCR.A mod X_Alignment /= 0 then @@ -19170,7 +19152,7 @@ package body Sem_Ch13 is -- Note: we do not check the alignment if we gave a size -- warning, since it would likely be redundant. - elsif not Alignment_Checks_Suppressed (ACCR) + elsif Check_Address_Alignment (ACCR.N) and then Y_Alignment /= Uint_0 and then (Y_Alignment < X_Alignment diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index aa15166..233f823 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5246,6 +5246,15 @@ package body Sem_Ch3 is and then Nkind (E) = N_Aggregate then Act_T := Etype (E); + + elsif Needs_Construction (T) + and then not Has_Init_Expression (N) + and then not Has_Default_Constructor (T) + and then not Suppress_Initialization (Id) + and then Comes_From_Source (N) + then + Error_Msg_NE ("no default constructor for&", + Object_Definition (N), T); end if; -- Check No_Wide_Characters restriction @@ -5944,6 +5953,8 @@ package body Sem_Ch3 is Set_Scalar_Range (Id, Scalar_Range (T)); Set_Digits_Value (Id, Digits_Value (T)); Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_IEEE_Extended_Precision + (Id, Is_IEEE_Extended_Precision (T)); -- If the floating point type has dimensions, these will be -- inherited subsequently when Analyze_Dimensions is called. @@ -8206,10 +8217,14 @@ package body Sem_Ch3 is Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); + Set_Is_IEEE_Extended_Precision + (Implicit_Base, Is_IEEE_Extended_Precision (Parent_Base)); if No_Constraint then Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); end if; + Set_Is_IEEE_Extended_Precision + (Derived_Type, Is_IEEE_Extended_Precision (Parent_Base)); elsif Is_Fixed_Point_Type (Parent_Type) then @@ -8500,26 +8515,28 @@ package body Sem_Ch3 is Full_P := Full_View (Parent_Type); -- A type extension of a type with unknown discriminants is an - -- indefinite type that the back-end cannot handle directly. + -- indefinite type that the back end cannot handle directly. -- We treat it as a private type, and build a completion that is -- derived from the full view of the parent, and hopefully has - -- known discriminants. + -- known discriminants. Note that the type will nevertheless be + -- turned into a public type in Build_Derived_Record_Type as for + -- any other extension; the only difference is the completion. -- If the full view of the parent type has an underlying record view, - -- use it to generate the underlying record view of this derived type + -- use it to generate the underlying record view of the derived type -- (required for chains of derivations with unknown discriminants). - -- Minor optimization: we avoid the generation of useless underlying - -- record view entities if the private type declaration has unknown - -- discriminants but its corresponding full view has no - -- discriminants. + -- Minor optimization: we avoid creating useless underlying record + -- view entities when the private type has unknown discriminants but + -- its corresponding full view has no discriminants. if Has_Unknown_Discriminants (Parent_Type) and then Present (Full_P) and then (Has_Discriminants (Full_P) or else Present (Underlying_Record_View (Full_P))) - and then not In_Open_Scopes (Par_Scope) - and then Expander_Active + and then (not In_Open_Scopes (Par_Scope) + or else not (In_Package_Body (Par_Scope) + or else In_Private_Part (Par_Scope))) then declare Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); @@ -8534,7 +8551,7 @@ package body Sem_Ch3 is -- Build anonymous completion, as a derivation from the full -- view of the parent. This is not a completion in the usual - -- sense, because the current type is not private. + -- sense, because the derived type is no longer private. Decl := Make_Full_Type_Declaration (Loc, @@ -8557,8 +8574,18 @@ package body Sem_Ch3 is Underlying_Record_View (Full_P)); end if; + -- If the extension is done in the public part of the scope of + -- the parent, its visible declarations have been installed, so + -- we first need to uninstall them before reinstalling both the + -- private and the visible declarations in this order. + + if In_Open_Scopes (Par_Scope) then + Uninstall_Declarations (Par_Scope); + end if; + Install_Private_Declarations (Par_Scope); Install_Visible_Declarations (Par_Scope); + Insert_Before (N, Decl); -- Mark entity as an underlying record view before analysis, @@ -8582,6 +8609,13 @@ package body Sem_Ch3 is Uninstall_Declarations (Par_Scope); + -- If the extension is done in the public part of the scope of + -- the parent, reinstall the visible declarations only. + + if In_Open_Scopes (Par_Scope) then + Install_Visible_Declarations (Par_Scope); + end if; + if Etype (Full_Der) = Any_Type then pragma Assert (Serious_Errors_Detected > 0); return; @@ -10007,13 +10041,15 @@ package body Sem_Ch3 is or else Unknown_Discriminants_Present (N)); -- The partial view of the parent may have unknown discriminants, - -- but if the full view has discriminants and the parent type is - -- in scope they must be inherited. + -- but when its full view has discriminants and is visible, then + -- these discriminants must be inherited. elsif Has_Unknown_Discriminants (Parent_Type) and then (not Has_Discriminants (Parent_Type) - or else not In_Open_Scopes (Scope (Parent_Base))) + or else not In_Open_Scopes (Scope (Parent_Base)) + or else not (In_Package_Body (Scope (Parent_Base)) + or else In_Private_Part (Scope (Parent_Base)))) then Set_Has_Unknown_Discriminants (Derived_Type); end if; @@ -15144,19 +15180,20 @@ package body Sem_Ch3 is Fixup_Bad_Constraint; return; - -- Check that the type has visible discriminants. The type may be - -- a private type with unknown discriminants whose full view has - -- discriminants which are invisible. + -- Check that the type has known discriminants - elsif not Has_Discriminants (T) - or else - (Has_Unknown_Discriminants (T) - and then Is_Private_Type (T)) - then + elsif Has_Unknown_Discriminants (T) then + Error_Msg_N ("invalid constraint: type has unknown discriminants", C); + Fixup_Bad_Constraint; + return; + + elsif not Has_Discriminants (T) then Error_Msg_N ("invalid constraint: type has no discriminant", C); Fixup_Bad_Constraint; return; + -- And is not already constrained + elsif Is_Constrained (E) or else (Ekind (E) = E_Class_Wide_Subtype and then Present (Discriminant_Constraint (E))) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5e84889..b752a6b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3843,7 +3843,8 @@ package body Sem_Ch6 is -- user entities, as internally generated entitities might still need -- to be expanded (e.g. those generated for types). - if Present (Ghost_Config.Ignored_Ghost_Region) + if not CodePeer_Mode + and then Present (Ghost_Config.Ignored_Ghost_Region) and then Comes_From_Source (Body_Id) then Expander_Active := False; @@ -5029,7 +5030,9 @@ package body Sem_Ch6 is end if; <<Leave>> - if Present (Ghost_Config.Ignored_Ghost_Region) then + if not CodePeer_Mode + and then Present (Ghost_Config.Ignored_Ghost_Region) + then Expander_Active := Saved_EA; end if; @@ -5270,10 +5273,95 @@ package body Sem_Ch6 is -- both subprogram bodies and subprogram declarations (specs). function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id); + -- This procedure checks whether the direct attribute definition for N + -- is correct for the given attribute name, and analyzes it. + function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean; -- Determine whether entity E denotes the spec or body of an invariant -- procedure. + ----------------------------------------- + -- Analyze_Direct_Attribute_Definition -- + ----------------------------------------- + + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id) is + Att_N : constant Node_Id := Original_Node (N); + Prefix_E : constant Entity_Id := + Get_Name_Entity_Id (Chars (Prefix (Defining_Unit_Name (Att_N)))); + Att_Name : constant Name_Id := + Attribute_Name (Defining_Unit_Name (Att_N)); + begin + pragma Assert (N /= Att_N); + + if not Is_Direct_Attribute_Definition_Name (Att_Name) then + Error_Msg_Name_1 := Att_Name; + Error_Msg_N + ("direct definition syntax not supported for attribute%", + Designator); + end if; + + -- Handle each kind of attribute separately + + case Att_Name is + + when Name_Constructor => + Error_Msg_Name_1 := Att_Name; + + -- No further action required in a subprogram body + + if Parent_Kind (N) not in N_Subprogram_Declaration then + return; + + elsif No (Prefix_E) or else not Is_Type (Prefix_E) then + Error_Msg_N + ("prefix& of attribute% must be a type", + Prefix (Defining_Unit_Name (Att_N))); + + elsif Ekind (Designator) /= E_Procedure then + Error_Msg_N + ("attribute% can only be specified to a procedure", N); + + elsif No (First_Formal (Designator)) + or else Etype (First_Formal (Designator)) /= Prefix_E + or else Ekind (First_Formal (Designator)) + /= E_In_Out_Parameter + then + declare + Problem : constant Source_Ptr := + (if No (First_Formal (Designator)) + then Sloc (N) + else Sloc (First_Formal (Designator))); + begin + Error_Msg_Node_1 := Defining_Unit_Name (Att_N); + Error_Msg_Node_2 := Prefix_E; + Error_Msg + ("& must have a first IN OUT formal of type&", Problem); + end; + + elsif Is_Frozen (Prefix_E) + or else Current_Scope /= Scope (Prefix_E) + then + Error_Msg_Sloc := Sloc (Freeze_Node (Prefix_E)); + Error_Msg_N + ("& must be defined before freezing#", Designator); + + elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator)) + /= N_Package_Specification + then + Error_Msg_N + ("& is required to be a primitive operation", Designator); + + else + Set_Needs_Construction (Prefix_E); + end if; + + when others => + null; + + end case; + end Analyze_Direct_Attribute_Definition; + ------------------------------------ -- Is_Invariant_Procedure_Or_Body -- ------------------------------------ @@ -5416,89 +5504,6 @@ package body Sem_Ch6 is End_Scope; - -- Register the subprogram in a Constructor_List when it is a valid - -- constructor. - - if All_Extensions_Allowed - and then Present (First_Formal (Designator)) - then - - declare - First_Form_Type : constant Entity_Id := - Etype (First_Formal (Designator)); - - Construct : Elmt_Id; - begin - -- Valid constructors have a "controlling" formal of a type - -- with the Constructor aspect specified. Additionally, the - -- subprogram name must match value described by the aspect. - - -- Additionally, constructor declarations must exist within the - -- same scope as the type declaration and before the type is - -- frozen. - - -- For example: - -- - -- type Foo is null record with Constructor => Bar; - -- - -- procedure Bar (Self : in out Foo); - -- - - if Present (Constructor_Name (First_Form_Type)) - and then Current_Scope = Scope (First_Form_Type) - and then Chars (Constructor_Name (First_Form_Type)) - = Chars (Designator) - and then Ekind (Designator) = E_Procedure - and then Nkind (Parent (N)) = N_Subprogram_Declaration - then - -- If the constructor list is empty than we don't have to - -- look for duplicates - we simply create the list and - -- add it. - - if No (Constructor_List (First_Form_Type)) then - Set_Constructor_List - (First_Form_Type, New_Elmt_List (Designator)); - - -- Otherwise, we need to check the constructor hasen't - -- already been added (e.g. a specification and body) and - -- that there isn't a constructor with the same number of - -- type of formals. - - -- NOTE: The Constructor_List is sorted by the number of - -- parameters. - - else - Construct := First_Elmt - (Constructor_List (First_Form_Type)); - - -- Skip over constructors with less than the number of - -- parameters than Designator ??? - - -- Loop through the constructors looking for ones which - -- "match." - - Outter : loop - - -- When we are at the end of the constructor list we - -- know there are no matches, so it is safe to add. - - if No (Construct) then - Append_Elmt - (Designator, - Constructor_List (First_Form_Type)); - exit Outter; - end if; - - -- Loop through the formals and check the formals - -- match on type ??? - - Next_Elmt (Construct); - end loop Outter; - end if; - end if; - end; - end if; - -- The subprogram scope is pushed and popped around the processing of -- the return type for consistency with call above to Process_Formals -- (which itself can call Analyze_Return_Type), and to ensure that any @@ -5511,6 +5516,12 @@ package body Sem_Ch6 is End_Scope; end if; + -- Handle subprogram specification directly referencing an attribute + + if Is_Direct_Attribute_Subp_Spec (N) then + Analyze_Direct_Attribute_Definition (Designator); + end if; + -- Function case if Nkind (N) = N_Function_Specification then diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 989e6bf..6032487 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -835,7 +835,8 @@ package body Sem_Ch7 is -- user entities, as internally generated entities might still need -- to be expanded (e.g. those generated for types). - if Present (Ghost_Config.Ignored_Ghost_Region) + if not CodePeer_Mode + and then Present (Ghost_Config.Ignored_Ghost_Region) and then Comes_From_Source (Body_Id) then Expander_Active := False; @@ -1148,7 +1149,9 @@ package body Sem_Ch7 is end if; end if; - if Present (Ghost_Config.Ignored_Ghost_Region) then + if not CodePeer_Mode and then + Present (Ghost_Config.Ignored_Ghost_Region) + then Expander_Active := Saved_EA; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 86344b5..fe7f311 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -136,7 +136,7 @@ package body Sem_Ch8 is -- the order of their corresponding scopes on the scope stack. For -- example, if package P and the enclosing scope both contain entities -- named E, then when compiling the package body the chain for E will - -- hold the global entity first, and the local one (corresponding to + -- hold the global entity first, and the local one (corresponding to -- the current inner scope) next. As a result, name resolution routines -- do not assume any relative ordering of the homonym chains, either -- for scope nesting or to order of appearance of context clauses. @@ -207,7 +207,7 @@ package body Sem_Ch8 is -- a private or incomplete type declaration, or a protected type speci- -- fication) and re-chained when compiling the second view. - -- In the case of operators, we do not make operators on derived types + -- In the case of operators, we do not make operators on derived types -- explicit. As a result, the notation P."+" may denote either a user- -- defined function with name "+", or else an implicit declaration of the -- operator "+" in package P. The resolution of expanded names always @@ -1892,7 +1892,7 @@ package body Sem_Ch8 is Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); if Old_S = Any_Id then - Error_Msg_N ("no subprogram or entry matches specification", N); + Error_Msg_N ("no subprogram or entry matches specification", N); else if Is_Body then Check_Subtype_Conformant (New_S, Old_S, N); @@ -2073,7 +2073,7 @@ package body Sem_Ch8 is end if; if Old_S = Any_Id then - Error_Msg_N ("no subprogram or entry matches specification", N); + Error_Msg_N ("no subprogram or entry matches specification", N); else if Is_Body then @@ -3848,7 +3848,7 @@ package body Sem_Ch8 is elsif Ekind (Old_S) /= E_Operator then -- If this a defaulted subprogram for a class-wide actual there is - -- no check for mode conformance, given that the signatures don't + -- no check for mode conformance, given that the signatures don't -- match (the source mentions T but the actual mentions T'Class). if CW_Actual then @@ -5213,7 +5213,7 @@ package body Sem_Ch8 is -- An entity in the current scope is not necessarily the first one -- on its homonym chain. Find its predecessor if any, -- If it is an internal entity, it will not be in the visibility - -- chain altogether, and there is nothing to unchain. + -- chain altogether, and there is nothing to unchain. if Id /= Current_Entity (Id) then Prev := Current_Entity (Id); @@ -5248,7 +5248,7 @@ package body Sem_Ch8 is Set_Name_Entity_Id (Chars (Id), Outer); elsif Scope (Prev) /= Scope (Id) then - Set_Homonym (Prev, Outer); + Set_Homonym (Prev, Outer); end if; <<Next_Ent>> @@ -5330,11 +5330,6 @@ package body Sem_Ch8 is --------------------- procedure End_Use_Package (N : Node_Id) is - Pack : Entity_Id; - Pack_Name : Node_Id; - Id : Entity_Id; - Elmt : Elmt_Id; - function Type_In_Use (T : Entity_Id; P : Entity_Id) return Boolean; -- Check whether type T is declared in P and appears in an active -- use_type clause. @@ -5349,6 +5344,14 @@ package body Sem_Ch8 is return Scope (BT) = P and then (In_Use (T) or else In_Use (BT)); end Type_In_Use; + -- Local variables + + Elmt : Elmt_Id; + Id : Entity_Id; + Pack : Entity_Id; + Pack_Name : Node_Id; + Scop : Entity_Id; + -- Start of processing for End_Use_Package begin @@ -5373,17 +5376,20 @@ package body Sem_Ch8 is -- Preserve use-visibility of operators that are primitive -- operators of a type that is use-visible through an active - -- use_type_clause. + -- use_type_clause. Note that we compare with the scope of + -- the operator and not Pack itself, lest Pack be a renaming. + + Scop := Scope (Id); if Nkind (Id) = N_Defining_Operator_Symbol and then - (Type_In_Use (Etype (Id), Pack) - or else Type_In_Use (Etype (First_Formal (Id)), Pack) + (Type_In_Use (Etype (Id), Scop) + or else Type_In_Use (Etype (First_Formal (Id)), Scop) or else (Present (Next_Formal (First_Formal (Id))) and then Type_In_Use - (Etype (Next_Formal (First_Formal (Id))), Pack))) + (Etype (Next_Formal (First_Formal (Id))), Scop))) then null; else @@ -7225,6 +7231,8 @@ package body Sem_Ch8 is begin while Present (Id) loop + -- The immediate case is when Id is an entity of the prefix + if Scope (Id) = P_Name then Candidate := Id; Is_New_Candidate := True; @@ -7250,6 +7258,53 @@ package body Sem_Ch8 is end if; end if; + -- If the name of a generic child unit appears within an instance + -- of itself, then it is resolved to the renaming of the name of + -- the instance built in Sem_Ch12, so we get to the generic parent + -- through the renaming. + + elsif Ekind (Id) in E_Function | E_Package | E_Procedure + and then Present (Renamed_Entity (Id)) + and then Is_Generic_Instance (Renamed_Entity (Id)) + and then In_Open_Scopes (Renamed_Entity (Id)) + then + declare + Gen_Inst : constant Entity_Id := Renamed_Entity (Id); + Gen_Par : constant Entity_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (Gen_Inst))); + + begin + -- The easy case is when Gen_Par is an entity of the prefix + + if Scope (Gen_Par) = P_Name then + Is_New_Candidate := True; + + -- Now the prefix may also be within an instance of itself, + -- but we do not need to go through the renaming for it, as + -- this was done on entry to the procedure. + + elsif Is_Generic_Instance (P_Name) + and then In_Open_Scopes (P_Name) + then + declare + Gen_Par_P : constant Entity_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (P_Name))); + + begin + if Scope (Gen_Par) = Gen_Par_P then + Is_New_Candidate := True; + else + Is_New_Candidate := False; + end if; + end; + + else + Is_New_Candidate := False; + end if; + end; + -- Ada 2005 (AI-217): Handle shadow entities associated with -- types declared in limited-withed nested packages. We don't need -- to handle E_Incomplete_Subtype entities because the entities @@ -7284,22 +7339,6 @@ package body Sem_Ch8 is Candidate := Get_Full_View (Id); Is_New_Candidate := True; - -- An unusual case arises with a fully qualified name for an - -- entity local to a generic child unit package, within an - -- instantiation of that package. The name of the unit now - -- denotes the renaming created within the instance. This is - -- only relevant in an instance body, see below. - - elsif Is_Generic_Instance (Scope (Id)) - and then In_Open_Scopes (Scope (Id)) - and then In_Instance_Body - and then Ekind (Scope (Id)) = E_Package - and then Ekind (Id) = E_Package - and then Renamed_Entity (Id) = Scope (Id) - and then Is_Immediately_Visible (P_Name) - then - Is_New_Candidate := True; - else Is_New_Candidate := False; end if; @@ -7434,55 +7473,6 @@ package body Sem_Ch8 is end if; else - -- Within the instantiation of a child unit, the prefix may - -- denote the parent instance, but the selector has the name - -- of the original child. That is to say, when A.B appears - -- within an instantiation of generic child unit B, the scope - -- stack includes an instance of A (P_Name) and an instance - -- of B under some other name. We scan the scope to find this - -- child instance, which is the desired entity. - -- Note that the parent may itself be a child instance, if - -- the reference is of the form A.B.C, in which case A.B has - -- already been rewritten with the proper entity. - - if In_Open_Scopes (P_Name) - and then Is_Generic_Instance (P_Name) - then - declare - Gen_Par : constant Entity_Id := - Generic_Parent (Specification - (Unit_Declaration_Node (P_Name))); - S : Entity_Id := Current_Scope; - P : Entity_Id; - - begin - for J in reverse 0 .. Scope_Stack.Last loop - S := Scope_Stack.Table (J).Entity; - - exit when S = Standard_Standard; - - if Ekind (S) in E_Function | E_Package | E_Procedure - then - P := - Generic_Parent (Specification - (Unit_Declaration_Node (S))); - - -- Check that P is a generic child of the generic - -- parent of the prefix. - - if Present (P) - and then Chars (P) = Chars (Selector) - and then Scope (P) = Gen_Par - then - Id := S; - goto Found; - end if; - end if; - - end loop; - end; - end if; - -- If this is a selection from Ada, System or Interfaces, then -- we assume a missing with for the corresponding package. @@ -7589,7 +7579,6 @@ package body Sem_Ch8 is end if; end if; - <<Found>> if Comes_From_Source (N) and then Is_Remote_Access_To_Subprogram_Type (Id) and then Ekind (Id) = E_Access_Subprogram_Type @@ -9959,9 +9948,7 @@ package body Sem_Ch8 is and then Scope (S) /= Standard_Standard and then not Is_Child_Unit (S) then - if Nkind (E) not in N_Entity then - return; - end if; + pragma Assert (Nkind (E) in N_Entity); -- Copy categorization flags from Scope (S) to S, this is not done -- when Scope (S) is Standard_Standard since propagation is from diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 5a8bd58..4a940e7f 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -586,7 +586,6 @@ package body Sem_Disp is Actual : Node_Id; Formal : Entity_Id; Control : Node_Id := Empty; - Func : Entity_Id; Subp_Entity : constant Entity_Id := Entity (Name (N)); Indeterm_Ctrl_Type : Entity_Id := Empty; @@ -1099,55 +1098,6 @@ package body Sem_Disp is Check_Dispatching_Context (N); - elsif Nkind (N) /= N_Function_Call then - - -- The call is not dispatching, so check that there aren't any - -- tag-indeterminate abstract calls left among its actuals. - - Actual := First_Actual (N); - while Present (Actual) loop - if Is_Tag_Indeterminate (Actual) then - - -- Function call case - - if Nkind (Original_Node (Actual)) = N_Function_Call then - Func := Entity (Name (Original_Node (Actual))); - - -- If the actual is an attribute then it can't be abstract - -- (the only current case of a tag-indeterminate attribute - -- is the stream Input attribute). - - elsif Nkind (Original_Node (Actual)) = N_Attribute_Reference - then - Func := Empty; - - -- Ditto if it is an explicit dereference - - elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference - then - Func := Empty; - - -- Only other possibility is a qualified expression whose - -- constituent expression is itself a call. - - else - Func := - Entity (Name (Original_Node - (Expression (Original_Node (Actual))))); - end if; - - if Present (Func) and then Is_Abstract_Subprogram (Func) then - Error_Msg_N - ("call to abstract function must be dispatching", - Actual); - end if; - end if; - - Next_Actual (Actual); - end loop; - - Check_Dispatching_Context (N); - elsif Nkind (Parent (N)) in N_Subexpr then Check_Dispatching_Context (N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0dc2e4f..0ebf421 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -16449,8 +16449,6 @@ package body Sem_Prag is or else not Is_Access_Type (Entity (Arg)) then Error_Pragma_Arg ("pragma% requires access type", Arg1); - else - Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); end if; end Controlled; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4d46755..bf9d5e1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -262,9 +262,8 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) return Node_Kind; - -- Utility to map the name of an operator into the corresponding Node. Used - -- by other node rewriting procedures. + Is_Binary : Boolean) return N_Op; + -- Map the name of an operator into the corresponding Node_Kind procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); -- Resolve actuals of call, and add default expressions for missing ones. @@ -1986,7 +1985,7 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) return Node_Kind + Is_Binary : Boolean) return N_Op is Kind : Node_Kind; @@ -10812,7 +10811,12 @@ package body Sem_Res is and then Is_Character_Type (Component_Type (Typ)) then Set_String_Literal_Subtype (Op1, Typ); - Set_String_Literal_Subtype (Op2, Typ); + + -- See Resolve_String_Literal for the asymmetry + + if Ekind (Etype (Op2)) /= E_String_Literal_Subtype then + Set_String_Literal_Subtype (Op2, Typ); + end if; end if; end Resolve_Op_Concat_Rest; @@ -12032,11 +12036,14 @@ package body Sem_Res is begin -- For a string appearing in a concatenation, defer creation of the -- string_literal_subtype until the end of the resolution of the - -- concatenation, because the literal may be constant-folded away. This - -- is a useful optimization for long concatenation expressions. + -- concatenation, because the literal may be constant-folded away. + -- This is a useful optimization for long concatenation expressions, + -- but it cannot be done if the string is the right operand and the + -- left operand may be null, because 4.5.3(5) says that the result is + -- the right operand and, in particular, has its original subtype. -- If the string is an aggregate built for a single character (which - -- happens in a non-static context) or a is null string to which special + -- happens in a non-static context) or is a null string to which special -- checks may apply, we build the subtype. Wide strings must also get a -- string subtype if they come from a one character aggregate. Strings -- generated by attributes might be static, but it is often hard to @@ -12049,6 +12056,11 @@ package body Sem_Res is or else Nkind (Parent (N)) /= N_Op_Concat or else (N /= Left_Opnd (Parent (N)) and then N /= Right_Opnd (Parent (N))) + or else (N = Right_Opnd (Parent (N)) + and then + (Nkind (Left_Opnd (Parent (N))) /= N_String_Literal + or else + String_Length (Strval (Left_Opnd (Parent (N)))) = 0)) or else ((Typ = Standard_Wide_String or else Typ = Standard_Wide_Wide_String) and then Nkind (Original_Node (N)) /= N_String_Literal); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 32d0833..31a2acd 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -610,14 +610,17 @@ package body Sem_Type is First_Interp := All_Interp.Last; Add_One_Interp (N, Ent, Etype (N)); - -- For expanded name, pick up all additional entities from the - -- same scope, since these are obviously also visible. Note that - -- these are not necessarily contiguous on the homonym chain. + -- For an expanded name, pick up additional visible entities from + -- the same scope. Note that these are not necessarily contiguous + -- on the homonym chain. if Nkind (N) = N_Expanded_Name then H := Homonym (Ent); while Present (H) loop - if Scope (H) = Scope (Entity (N)) then + if Scope (H) = Scope (Entity (N)) + and then (not Is_Hidden (H) + or else Is_Immediately_Visible (H)) + then Add_One_Interp (N, H, Etype (H)); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a8984c8..cacf29c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6332,6 +6332,26 @@ package body Sem_Util is end Conditional_Delay; -------------------------------------- + -- Direct_Attribute_Definition_Name -- + -------------------------------------- + + function Direct_Attribute_Definition_Name + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id is + begin + if Nkind (Prefix) = N_Attribute_Reference then + Error_Msg_N ("attribute streams not supported in " + & "direct attribute definitions", + Prefix); + end if; + + pragma Assert (Is_Attribute_Name (Att_Name)); + return New_External_Name + (Related_Id => Chars (Prefix), + Suffix => "_" & Get_Name_String (Att_Name) & "_Att", + Prefix => 'D'); + end Direct_Attribute_Definition_Name; + + -------------------------------------- -- Copy_Assertion_Policy_Attributes -- -------------------------------------- @@ -6832,30 +6852,6 @@ package body Sem_Util is return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ); end CW_Or_Needs_Finalization; - ------------------------- - -- Default_Constructor -- - ------------------------- - - function Default_Constructor (Typ : Entity_Id) return Entity_Id is - Construct : Elmt_Id; - begin - pragma Assert (Is_Type (Typ)); - if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then - return Empty; - end if; - - Construct := First_Elmt (Constructor_List (Typ)); - while Present (Construct) loop - if Parameter_Count (Elists.Node (Construct)) = 1 then - return Elists.Node (Construct); - end if; - - Next_Elmt (Construct); - end loop; - - return Empty; - end Default_Constructor; - --------------------- -- Defining_Entity -- --------------------- @@ -11850,6 +11846,35 @@ package body Sem_Util is (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; + ----------------------------- + -- Has_Default_Constructor -- + ----------------------------- + + function Has_Default_Constructor (Typ : Entity_Id) return Boolean is + Cursor : Entity_Id; + begin + pragma Assert (Is_Type (Typ)); + if not Needs_Construction (Typ) then + return False; + end if; + + -- Iterate through all homonyms to find the default constructor + + Cursor := Get_Name_Entity_Id + (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + while Present (Cursor) loop + if Is_Constructor_Procedure (Cursor) + and then No (Next_Formal (First_Formal (Cursor))) + then + return True; + end if; + + Cursor := Homonym (Cursor); + end loop; + + return False; + end Has_Default_Constructor; + ------------------- -- Has_Denormals -- ------------------- @@ -16249,6 +16274,17 @@ package body Sem_Util is and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; + ----------------------------------- + -- Is_Direct_Attribute_Subp_Spec -- + ----------------------------------- + + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean is + begin + return Nkind (N) in N_Subprogram_Specification + and then Nkind (Defining_Unit_Name (Original_Node (N))) + = N_Attribute_Reference; + end Is_Direct_Attribute_Subp_Spec; + ------------------------- -- Is_Attribute_Update -- ------------------------- @@ -16684,6 +16720,28 @@ package body Sem_Util is end if; end Is_Constant_Bound; + ------------------------------ + -- Is_Constructor_Procedure -- + ------------------------------ + + function Is_Constructor_Procedure (Subp : Entity_Id) return Boolean is + First_Param : Entity_Id; + begin + if not (Present (First_Formal (Subp)) + and then Ekind (First_Formal (Subp)) = E_In_Out_Parameter + and then Is_Direct_Attribute_Subp_Spec (Parent (Subp)) + and then Attribute_Name (Defining_Unit_Name + (Original_Node (Parent (Subp)))) + = Name_Constructor) + then + return False; + end if; + + First_Param := Implementation_Base_Type (Etype (First_Formal (Subp))); + return Scope (Subp) = Scope (First_Param) + and then Needs_Construction (First_Param); + end Is_Constructor_Procedure; + --------------------------- -- Is_Container_Element -- --------------------------- @@ -24817,10 +24875,20 @@ package body Sem_Util is -- Scalar_Range if Is_Discrete_Type (Id) then + + -- The scalar range of the source entity had a parent, so the + -- scalar range of the newly created entity should also have a + -- parent, so that the AST structure is the same. + + pragma Assert (Present (Parent (Scalar_Range (Id)))); + Set_Scalar_Range (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Scalar_Range (Id)), Semantic => True))); + + pragma Assert (No (Parent (Scalar_Range (Id)))); + Set_Parent (Scalar_Range (Id), Id); end if; -- Scope @@ -26669,24 +26737,6 @@ package body Sem_Util is return Empty; end Param_Entity; - --------------------- - -- Parameter_Count -- - --------------------- - - function Parameter_Count (Subp : Entity_Id) return Nat is - Result : Nat := 0; - Param : Entity_Id; - begin - Param := First_Entity (Subp); - while Present (Param) loop - Result := Result + 1; - - Param := Next_Entity (Param); - end loop; - - return Result; - end Parameter_Count; - ---------------------- -- Policy_In_Effect -- ---------------------- @@ -27097,6 +27147,11 @@ package body Sem_Util is -- the case where Ent is a child unit. This procedure generates an -- appropriate cross-reference entry. E is the corresponding entity. + procedure Get_Attribute_Reference_Name_String (N : Node_Id); + -- This procedure append to the Global_Name_Buffer the decoded string + -- name of the attribute reference N, including apostrophes and multiple + -- prefixes. + ------------------------- -- Generate_Parent_Ref -- ------------------------- @@ -27118,6 +27173,21 @@ package body Sem_Util is end if; end Generate_Parent_Ref; + ----------------------------------------- + -- Get_Attribute_Reference_Name_String -- + ----------------------------------------- + + procedure Get_Attribute_Reference_Name_String (N : Node_Id) is + begin + if Nkind (N) /= N_Attribute_Reference then + Get_Decoded_Name_String (Chars (N)); + else + Get_Attribute_Reference_Name_String (Prefix (N)); + Append (Global_Name_Buffer, '''); + Get_Decoded_Name_String (Attribute_Name (N)); + end if; + end Get_Attribute_Reference_Name_String; + -- Start of processing for Process_End_Label begin @@ -27198,9 +27268,12 @@ package body Sem_Util is -- If the end label is not for the given entity, then either we have -- some previous error, or this is a generic instantiation for which -- we do not need to make a cross-reference in this case anyway. In - -- either case we simply ignore the call. + -- either case we simply ignore the call. Matching label for direct + -- attribute definitions are checked elsewhere. - if Chars (Ent) /= Chars (Endl) then + if Nkind (Endl) /= N_Attribute_Reference + and then Chars (Ent) /= Chars (Endl) + then return; end if; @@ -27227,7 +27300,7 @@ package body Sem_Util is -- mean the semicolon immediately following the label). This is -- done for the sake of the 'e' or 't' entry generated below. - Get_Decoded_Name_String (Chars (Endl)); + Get_Attribute_Reference_Name_String (Endl); Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ee9ecd2..71889b2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -569,6 +569,10 @@ package Sem_Util is -- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is -- False). + function Direct_Attribute_Definition_Name + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id; + -- Returns the name used for entities of direct attribute definitions. + procedure Copy_Assertion_Policy_Attributes (New_Prag, Old_Prag : Node_Id); -- Copy Is_Checked, Is_Ignored and Ghost_Assertion_Level attributes from -- Old_Node. @@ -674,10 +678,6 @@ package Sem_Util is -- as Needs_Finalization except with pragma Restrictions (No_Finalization), -- in which case we know that class-wide objects do not need finalization. - function Default_Constructor (Typ : Entity_Id) return Entity_Id; - -- Determine the default constructor (e.g. the constructor with only one - -- formal parameter) for a given type Typ. - function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -1407,6 +1407,9 @@ package Sem_Util is function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; -- Simple predicate to test for defaulted discriminants + function Has_Default_Constructor (Typ : Entity_Id) return Boolean; + -- Determine whether Typ has a constructor with only one formal parameter. + function Has_Denormals (E : Entity_Id) return Boolean; -- Determines if the floating-point type E supports denormal numbers. -- Returns False if E is not a floating-point type. @@ -1880,6 +1883,10 @@ package Sem_Util is function Is_Attribute_Result (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Result + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean; + -- Determine whether N denotes a direct attribute definition subprogram + -- specification node. + function Is_Attribute_Update (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Update @@ -1914,6 +1921,10 @@ package Sem_Util is -- enumeration literal, or an expression composed of constant-bound -- subexpressions which are evaluated by means of standard operators. + function Is_Constructor_Procedure (Subp : Entity_Id) return Boolean; + -- Returns True if Subp's name directly references an attribute, has a + -- first in out formal that needs construction within the same scope. + function Is_Container_Element (Exp : Node_Id) return Boolean; -- This routine recognizes expressions that denote an element of one of -- the predefined containers, when the source only contains an indexing @@ -2973,9 +2984,6 @@ package Sem_Util is -- WARNING: this routine should be used in debugging scenarios such as -- tracking down undefined symbols as it is fairly low level. - function Parameter_Count (Subp : Entity_Id) return Nat; - -- Return the number of parameters for a given subprogram Subp. - function Param_Entity (N : Node_Id) return Entity_Id; -- Given an expression N, determines if the expression is a reference -- to a formal (of a subprogram or entry), and if so returns the Id diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2c15b80..8a35fdc 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -690,7 +690,6 @@ package Sinfo is -- Do_Discriminant_Check -- Do_Length_Check - -- Do_Storage_Check -- These flags are used in some specific cases by the front end, either -- during semantic analysis or during expansion, and cannot be expected @@ -1003,9 +1002,10 @@ package Sinfo is -- to the defining entity for the corresponding body (NOT the node for -- the body itself). - -- Corresponding_Entry_Body + -- Corresponding_Entry_Body -- Defined in N_Subprogram_Body. Set for subprogram bodies that implement -- a protected type entry; points to the body for the entry. + -- Used by codepeer. -- Corresponding_Formal_Spec -- This field is set in subprogram renaming declarations, where it points @@ -1057,13 +1057,6 @@ package Sinfo is -- This field is present in an N_Variant node, It references the entity -- for the discriminant checking function for the variant. - -- Default_Expression - -- This field is Empty if there is no default expression. If there is a - -- simple default expression (one with no side effects), then this field - -- simply contains a copy of the Expression field (both point to the tree - -- for the default expression). Default_Expression is used for - -- conformance checking. - -- Default_Storage_Pool -- This field is present in N_Compilation_Unit_Aux nodes. It is set to a -- copy of Opt.Default_Pool at the end of the compilation unit. See @@ -1151,14 +1144,6 @@ package Sinfo is -- listed above (e.g. in a return statement), an additional type -- conversion node is introduced to represent the required check. - -- Do_Storage_Check - -- This flag is set in an N_Allocator node to indicate that a storage - -- check is required for the allocation, or in an N_Subprogram_Body node - -- to indicate that a stack check is required in the subprogram prologue. - -- The N_Allocator case is handled by the routine that expands the call - -- to the runtime routine. The N_Subprogram_Body case is handled by the - -- backend, and all the semantics does is set the flag. - -- Elaborate_Present -- This flag is set in the N_With_Clause node to indicate that pragma -- Elaborate pragma appears for the with'ed units. @@ -1188,12 +1173,6 @@ package Sinfo is -- need for this field, so in the tree passed to Gigi, this field is -- always set to No_List. - -- Enclosing_Variant - -- This field is present in the N_Variant node and identifies the Node_Id - -- corresponding to the immediately enclosing variant when the variant is - -- nested, and N_Empty otherwise. Set during semantic processing of the - -- variant part of a record type. - -- Entity -- Appears in all direct names (identifiers, character literals, and -- operator symbols), as well as expanded names, and attributes that @@ -1394,14 +1373,6 @@ package Sinfo is -- Generic_Parent_Type is also used in an instance to determine whether a -- private operation overrides an inherited one. - -- Handler_List_Entry - -- This field is present in N_Object_Declaration nodes. It is set only - -- for the Handler_Record entry generated for an exception in zero cost - -- exception handling mode. It references the corresponding item in the - -- handler list, and is used to delete this entry if the corresponding - -- handler is deleted during optimization. For further details on why - -- this is required, see Exp_Ch11.Remove_Handler_Entries. - -- Has_Dereference_Action -- This flag is present in N_Explicit_Dereference nodes. It is set to -- indicate that the expansion has aready produced a call to primitive @@ -1884,11 +1855,6 @@ package Sinfo is -- the generic unit on the actual parameters done in the outermost scope -- where it would be legal to declare an identical named instantiation. - -- Is_Subprogram_Descriptor - -- Present in N_Object_Declaration, and set only for the object - -- declaration generated for a subprogram descriptor in fast exception - -- mode. See Exp_Ch11 for details of use. - -- Is_Task_Allocation_Block -- A flag set in a Block_Statement node to indicate that it is the -- expansion of a task allocator, or the allocator of an object @@ -2237,14 +2203,6 @@ package Sinfo is -- to indicate that a use is redundant (and therefore need not be undone -- on scope exit). - -- Renaming_Exception - -- Present in N_Exception_Declaration node. Used to point back to the - -- exception renaming for an exception declared within a subprogram. - -- What happens is that an exception declared in a subprogram is moved - -- to the library level with a unique name, and the original exception - -- becomes a renaming. This link from the library level exception to the - -- renaming declaration allows registering of the proper exception name. - -- Return_Statement_Entity -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement. -- Points to an E_Return_Statement representing the return statement. @@ -3020,14 +2978,12 @@ package Sinfo is -- Null_Exclusion_Present -- Object_Definition subtype indic./array type def./access def. -- Expression (set to Empty if not present) - -- Handler_List_Entry -- Corresponding_Generic_Association -- More_Ids (set to False if no more identifiers in list) -- Prev_Ids (set to False if no previous identifiers in list) -- No_Initialization -- Assignment_OK -- Exception_Junk - -- Is_Subprogram_Descriptor -- Has_Init_Expression -- Suppress_Assignment_Checks @@ -3632,7 +3588,6 @@ package Sinfo is -- Sloc points to WHEN -- Discrete_Choices -- Component_List - -- Enclosing_Variant -- Present_Expr -- Dcheck_Function -- Has_SP_Choice @@ -4853,7 +4808,6 @@ package Sinfo is -- Null_Exclusion_Present -- No_Initialization -- Is_Static_Coextension - -- Do_Storage_Check -- Is_Dynamic_Coextension -- plus fields for expression @@ -5505,10 +5459,9 @@ package Sinfo is -- Out_Present -- Null_Exclusion_Present -- Parameter_Type subtype mark or access definition - -- Expression (set to Empty if no default expression present) + -- Expression (set to Empty if no default expression) -- More_Ids (set to False if no more identifiers in list) -- Prev_Ids (set to False if no previous identifiers in list) - -- Default_Expression --------------- -- 6.1 Mode -- @@ -5541,7 +5494,6 @@ package Sinfo is -- At_End_Proc (set to Empty if no clean up procedure) -- Acts_As_Spec -- Bad_Is_Detected used only by parser - -- Do_Storage_Check -- Has_Relative_Deadline_Pragma -- Is_Entry_Barrier_Function -- Is_Protected_Subprogram_Body @@ -6887,11 +6839,16 @@ package Sinfo is -- N_Exception_Declaration -- Sloc points to EXCEPTION -- Defining_Identifier - -- Expression - -- Renaming_Exception + -- Expression (see below) -- More_Ids (set to False if no more identifiers in list) -- Prev_Ids (set to False if no previous identifiers in list) + -- Expression is not present in the syntax; it is set during expansion. + -- An exception_declaration is treated by the back end like an object of + -- type Standard.Exception_Type, and Expression is the initial value. + -- Expression is a syntactic field to match the Expression fields of + -- other node kinds. + ------------------------------------------ -- 11.2 Handled Sequence Of Statements -- ------------------------------------------ @@ -7236,7 +7193,7 @@ package Sinfo is -- Null_Exclusion_Present (set to False if not present) -- Subtype_Mark (set to Empty if not present) -- Access_Definition (set to Empty if not present) - -- Default_Expression (set to Empty if no default expression) + -- Expression (set to Empty if no default expression) -- More_Ids (set to False if no more identifiers in list) -- Prev_Ids (set to False if no previous identifiers in list) @@ -7987,6 +7944,9 @@ package Sinfo is -- N_Compound_Statement -- Actions + -- Note that N_Compound_Statement is unrelated to the Ada syntax rule + -- for compound_statement. + -------------- -- Contract -- -------------- diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index fcfd390..b5f53cd 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -412,6 +412,15 @@ package body Snames is end if; end Is_Convention_Name; + ----------------------------------------- + -- Is_Direct_Attribute_Definition_Name -- + ----------------------------------------- + + function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean is + begin + return Is_Attribute_Name (N) and then N = Name_Constructor; + end Is_Direct_Attribute_Definition_Name; + ------------------------------ -- Is_Entity_Attribute_Name -- ------------------------------ diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index d6fe60b..cb07f97 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -147,7 +147,6 @@ package Snames is -- Names of aspects for which there are no matching pragmas or attributes -- so that they need to be included for aspect specification use. - Name_Constructor : constant Name_Id := N + $; Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; Name_Designated_Storage_Model : constant Name_Id := N + $; @@ -956,6 +955,7 @@ package Snames is Name_Component_Size : constant Name_Id := N + $; Name_Compose : constant Name_Id := N + $; Name_Constrained : constant Name_Id := N + $; + Name_Constructor : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT Name_Default_Scalar_Storage_Order : constant Name_Id := N + $; -- GNAT @@ -1500,6 +1500,7 @@ package Snames is Attribute_Component_Size, Attribute_Compose, Attribute_Constrained, + Attribute_Constructor, Attribute_Count, Attribute_Default_Bit_Order, Attribute_Default_Scalar_Storage_Order, @@ -2077,6 +2078,10 @@ package Snames is -- mode. This is the mechanism for considering this pragma illegal in -- normal GNAT programs. + function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute and is + -- allowed to be directly referenced in subprogram specification. + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized entity attribute, -- i.e. an attribute reference that returns an entity. diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index f5caa3d..8c49864 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1963,9 +1963,9 @@ package body Sprint is Sprint_Node (Access_Definition (Node)); end if; - if Present (Default_Expression (Node)) then + if Present (Expression (Node)) then Write_Str (" := "); - Sprint_Node (Default_Expression (Node)); + Sprint_Node (Expression (Node)); end if; Write_Char (';'); diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 6e5688d..56d1060 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -345,12 +345,14 @@ package body Style is begin if Style_Check_Xtra_Parens_Precedence and then - Paren_Count (N) > - (if Nkind (N) in N_Case_Expression - | N_Expression_With_Actions - | N_If_Expression - | N_Quantified_Expression - | N_Raise_Expression + Paren_Count (Original_Node (N)) > + (if Nkind (Original_Node (N)) in N_Case_Expression + | N_Expression_With_Actions + | N_If_Expression + | N_Quantified_Expression + | N_Raise_Expression + | N_In + | N_Not_In then 1 else 0) then diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index fbad71a..9d78987 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -338,6 +338,8 @@ package body Treepr is return "Is_Elaboration_Checks_OK_Id"; when F_Is_Elaboration_Warnings_OK_Id => return "Is_Elaboration_Warnings_OK_Id"; + when F_Is_IEEE_Extended_Precision => + return "Is_IEEE_Extended_Precision"; when F_Is_RACW_Stub_Type => return "Is_RACW_Stub_Type"; when F_LSP_Subprogram => |