diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 88bfeb73b02..353d0a5f1be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,73 @@ +2014-10-23 Ed Schonberg + + * sem_ch6.adb (Analyze_Expression_Function): Simplify analysis + in generic context, and generate body in this case as well, + to simplify ASIS traversals on the construct. + +2014-10-23 Ed Schonberg + + * sem_ch4.adb (Complete_Object_Operation): Indicate that the + scope of the operation (s) is referenced, to prevent spurious + warnings about unused units. + +2014-10-23 Johannes Kanig + + * errout.adb (Error_Msg_Internal): Copy check flag, increment + check msg count. + * erroutc.adb (Delete_Msg) adjust check msg count. + (Output_Msg_Text) handle check msg case (do nothing). + (Prescan_Message) recognize check messages with severity prefixes. + * errutil.adb (Error_Msg) handle check flag, adjust counter. + +2014-10-23 Ed Schonberg + + * sem_eval.adb (Subtypes_Statically_Match): For a generic actual + type, check for the presence of discriminants in its parent type, + against the presence of discriminants in the context type. + +2014-10-23 Tristan Gingold + + * adaint.c: __gnat_get_file_names_case_sensitive: Default is + true on arm-darwin. + +2014-10-23 Arnaud Charlet + + * pprint.adb (Expression_Image): Add handling of quantifiers. + +2014-10-23 Ed Schonberg + + * exp_pakd.adb (Expand_Packed_Element_Reference): If the + prefix is a source entity, generate a reference to it before + transformation, because rewritten node might not generate a + proper reference, leading to spurious warnings. + +2014-10-23 Tristan Gingold + + * init.c: Fix thinko in previous patch. + +2014-10-23 Hristian Kirtchev + + * sem_ch3.adb (Decimal_Fixed_Point_Type_Declaration): + Inherit the rep chain of the implicit base type. + (Floating_Point_Type_Declaration): Inherit the rep chain of the + implicit base type. + (Ordinary_Fixed_Point_Type_Declaration): Inherit the rep chain of the + implicit base type. + (Signed_Integer_Type_Declaration): Inherit the rep chain of the + implicit base type. + * sem_util.ads, sem_util.adb (Inherit_Rep_Item_Chain): New routine. + +2014-10-23 Pascal Obry + + * g-regist.adb, g-regist.ads: Add support for reading 32bit or 64bit + view of the registry. + +2014-10-23 Ed Schonberg + + * exp_ch3.adb (Expand_N_Object_Declaration): If type is abstract, + return without expanding expression, to prevent subsequent crash. + * freeze.adb: better error message for illegal declaration. + 2014-10-23 Hristian Kirtchev * sysdep.c (__gnat_localtime_tzoff): Properly delimit the diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 02bce453297..0acaa74d3ab 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -547,11 +547,15 @@ __gnat_get_file_names_case_sensitive (void) && sensitive[1] == '\0') file_names_case_sensitive_cache = sensitive[0] - '0'; else -#if defined (WINNT) || defined (__APPLE__) - file_names_case_sensitive_cache = 0; + { + /* By default, we suppose filesystems aren't case sensitive on + Windows and Darwin (but they are on arm-darwin). */ +#if defined (WINNT) || (defined (__APPLE__) && !defined (__arm__)) + file_names_case_sensitive_cache = 0; #else - file_names_case_sensitive_cache = 1; + file_names_case_sensitive_cache = 1; #endif + } } return file_names_case_sensitive_cache; } diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 37b276e9cdb..3bc71f5974d 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -320,6 +320,10 @@ package Atree is -- Number of info messages generated. Info messages are neved treated as -- errors (whether from use of the pragma, or the compiler switch -gnatwe). + Check_Messages : Nat := 0; + -- Number of check messages generated. Check messages are neither warnings + -- nor errors. + Warnings_Treated_As_Errors : Nat := 0; -- Number of warnings changed into errors as a result of matching a pattern -- given in a Warning_As_Error configuration pragma. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index e540b41a3dd..911820c0363 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -982,6 +982,7 @@ package body Errout is Col => Get_Column_Number (Sptr), Warn => Is_Warning_Msg, Info => Is_Info_Msg, + Check => Is_Check_Msg, Warn_Err => False, -- reset below Warn_Chr => Warning_Msg_Char, Style => Is_Style_Msg, @@ -1140,6 +1141,9 @@ package body Errout is Info_Messages := Info_Messages + 1; end if; + elsif Errors.Table (Cur_Msg).Check then + Check_Messages := Check_Messages + 1; + else Total_Errors_Detected := Total_Errors_Detected + 1; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index ef4a9cf682b..6ca45497fde 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -413,6 +413,13 @@ package Errout is -- are continuations that are not printed using the -gnatj switch they -- will also have this prefix. + -- Insertion sequence "low: " or "medium: " or "high: " (check message) + -- This appears only at the start of the message (and not any of its + -- continuations, if any), and indicates that the message is a check + -- message. The message will be output with this prefix. Check + -- messages are not fatal (so are like info messages in that respect) + -- and are not controlled by pragma Warnings. + ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index f4f1dfd1c8d..32d9bbc7865 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -145,6 +145,9 @@ package body Erroutc is -- because this only gets incremented if we actually output the -- message, which we won't do if we are deleting it here! + elsif Errors.Table (D).Check then + Check_Messages := Check_Messages - 1; + else Total_Errors_Detected := Total_Errors_Detected - 1; @@ -653,6 +656,11 @@ package body Erroutc is elsif Errors.Table (E).Style then null; + -- No prefix needed for check message, severity is there already + + elsif Errors.Table (E).Check then + null; + -- All other cases, add "error: " if unique error tag set elsif Opt.Unique_Error_Tag then @@ -765,6 +773,15 @@ package body Erroutc is Is_Info_Msg := Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: "; + -- Check check message + + Is_Check_Msg := + (Msg'Length > 8 and then Msg (Msg'First .. Msg'First + 7) = "medium: ") + or else + (Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "high: ") + or else + (Msg'Length > 5 and then Msg (Msg'First .. Msg'First + 4) = "low: "); + -- Loop through message looking for relevant insertion sequences J := Msg'First; @@ -833,7 +850,7 @@ package body Erroutc is end if; end loop; - if Is_Warning_Msg or Is_Style_Msg then + if Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then Is_Serious_Error := False; end if; end Prescan_Message; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index f23f4df588f..cb69f17f8b9 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -68,6 +68,10 @@ package Erroutc is -- "info: " and is to be treated as an information message. This string -- will be prepended to the message and all its continuations. + Is_Check_Msg : Boolean := False; + -- Set True to indicate that the current message starts with one of + -- "high: ", "medium: ", "low: " and is to be treated as a check message. + Warning_Msg_Char : Character; -- Warning character, valid only if Is_Warning_Msg is True -- ' ' -- ? or < appeared on its own in message @@ -208,6 +212,9 @@ package Erroutc is Info : Boolean; -- True if info message + Check : Boolean; + -- True if check message + Warn_Err : Boolean; -- True if this is a warning message which is to be treated as an error -- as a result of a match with a Warning_As_Error pragma. diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 7eb85a4193a..9fd67e16a74 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -213,6 +213,7 @@ package body Errutil is Col => Get_Column_Number (Sptr), Warn => Is_Warning_Msg, Info => Is_Info_Msg, + Check => Is_Check_Msg, Warn_Err => Warning_Mode = Treat_As_Error, Warn_Chr => Warning_Msg_Char, Style => Is_Style_Msg, @@ -313,6 +314,9 @@ package body Errutil is Info_Messages := Info_Messages + 1; end if; + elsif Errors.Table (Cur_Msg).Check then + Check_Messages := Check_Messages + 1; + else Total_Errors_Detected := Total_Errors_Detected + 1; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3aecc9ba370..1480c0fa525 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5346,6 +5346,14 @@ package body Exp_Ch3 is return; end if; + -- The type of the object cannot be abstract. This is diagnosed at the + -- point the object is frozen, which happens after the declaration is + -- fully expanded, so simply return now. + + if Is_Abstract_Type (Typ) then + return; + end if; + -- First we do special processing for objects of a tagged type where -- this is the point at which the type is frozen. The creation of the -- dispatch table and the initialization procedure have to be deferred diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 21487c0b3f5..e6bcb999869 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -30,6 +30,7 @@ with Errout; use Errout; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; with Layout; use Layout; +with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -1682,6 +1683,16 @@ package body Exp_Pakd is Expand_Packed_Element_Reference (Prefix (N)); end if; + -- The prefix may be rewritten below as a conversion. If it is a source + -- entity generate reference to it now, to prevent spurious warnings + -- about unused entities. + + if Is_Entity_Name (Prefix (N)) + and then Comes_From_Source (Prefix (N)) + then + Generate_Reference (Entity (Prefix (N)), Prefix (N), 'r'); + end if; + -- If not bit packed, we have the enumeration case, which is easily -- dealt with (just adjust the subscripts of the indexed component) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 156afda2e65..44921d0243c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4498,6 +4498,11 @@ package body Freeze is Error_Msg_NE ("\} may need a cpp_constructor", Object_Definition (Parent (E)), Etype (E)); + + elsif Present (Expression (Parent (E))) then + Error_Msg_N -- CODEFIX + ("\maybe a class-wide type was meant", + Object_Definition (Parent (E))); end if; end if; diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb index ba63b3c8326..4d989630151 100644 --- a/gcc/ada/g-regist.adb +++ b/gcc/ada/g-regist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -529,16 +529,24 @@ package body GNAT.Registry is function To_C_Mode (Mode : Key_Mode) return REGSAM is use type REGSAM; - KEY_READ : constant := 16#20019#; - KEY_WRITE : constant := 16#20006#; + KEY_READ : constant := 16#20019#; + KEY_WRITE : constant := 16#20006#; + KEY_WOW64_64KEY : constant := 16#00100#; + KEY_WOW64_32KEY : constant := 16#00200#; begin case Mode is when Read_Only => - return KEY_READ; + return KEY_READ + KEY_WOW64_32KEY; when Read_Write => - return KEY_READ + KEY_WRITE; + return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY; + + when Read_Only_64 => + return KEY_READ + KEY_WOW64_64KEY; + + when Read_Write_64 => + return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY; end case; end To_C_Mode; diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads index c7ad4dcfe11..0222a1079ef 100644 --- a/gcc/ada/g-regist.ads +++ b/gcc/ada/g-regist.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,8 +54,12 @@ package GNAT.Registry is HKEY_USERS : constant HKEY; HKEY_PERFORMANCE_DATA : constant HKEY; - type Key_Mode is (Read_Only, Read_Write); - -- Access mode for the registry key + type Key_Mode is + (Read_Only, Read_Write, -- operates on 32bit view of the registry + Read_Only_64, Read_Write_64); -- operates on 64bit view of the registry + -- Access mode for the registry key. The *_64 are only meaningful on + -- Windows 64bit and ignored on Windows 32bit where _64 are equivalent to + -- the non 64bit versions. Registry_Error : exception; -- Registry_Error is raises by all routines below if a problem occurs diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 9a229053494..8a33966d62b 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2238,7 +2238,7 @@ __gnat_is_stack_guard (mach_vm_address_t addr) return 0; #else /* Pagezero for arm. */ - return addr < 4096; + return addr >= 4096; #endif } diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index 8ac3ac63688..f726b644bad 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -623,6 +623,9 @@ package body Pprint is exit; end if; + when N_Quantified_Expression => + Right := Original_Node (Condition (Right)); + -- For all other items, quit the loop when others => diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e29b65ace0d..27c228647d8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -13914,17 +13914,19 @@ package body Sem_Ch3 is Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); end if; - -- Complete entity for first subtype + -- Complete entity for first subtype. The inheritance of the rep item + -- chain ensures that SPARK-related pragmas are not clobbered when the + -- decimal fixed point type acts as a full view of a private type. - Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Set_Size_Info (T, Implicit_Base); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); - Set_Delta_Value (T, Delta_Val); - Set_Small_Value (T, Delta_Val); - Set_Scale_Value (T, Scale_Val); - Set_Is_Constrained (T); + Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Inherit_Rep_Item_Chain (T, Implicit_Base); + Set_Digits_Value (T, Digs_Val); + Set_Delta_Value (T, Delta_Val); + Set_Small_Value (T, Delta_Val); + Set_Scale_Value (T, Scale_Val); + Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; ----------------------------------- @@ -16725,24 +16727,25 @@ package body Sem_Ch3 is Set_Scalar_Range (T, Scalar_Range (Base_Typ)); end if; - -- Complete definition of implicit base and declared first subtype + -- Complete definition of implicit base and declared first subtype. The + -- inheritance of the rep item chain ensures that SPARK-related pragmas + -- are not clobbered when the floating point type acts as a full view of + -- a private type. - Set_Etype (Implicit_Base, Base_Typ); + Set_Etype (Implicit_Base, Base_Typ); + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); + Set_Size_Info (Implicit_Base, Base_Typ); + Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); + Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - Set_Size_Info (Implicit_Base, (Base_Typ)); - Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); - Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); - Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); - Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - - Set_Ekind (T, E_Floating_Point_Subtype); - Set_Etype (T, Implicit_Base); - - Set_Size_Info (T, (Implicit_Base)); - Set_RM_Size (T, RM_Size (Implicit_Base)); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); + Set_Ekind (T, E_Floating_Point_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Set_RM_Size (T, RM_Size (Implicit_Base)); + Inherit_Rep_Item_Chain (T, Implicit_Base); + Set_Digits_Value (T, Digs_Val); end Floating_Point_Type_Declaration; ---------------------------- @@ -18436,15 +18439,17 @@ package body Sem_Ch3 is Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); Set_Fixed_Range (T, Loc, Low_Val, High_Val); - -- Complete definition of first subtype + -- Complete definition of first subtype. The inheritance of the rep item + -- chain ensures that SPARK-related pragmas are not clobbered when the + -- ordinary fixed point type acts as a full view of a private type. - Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Init_Size_Align (T); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Small_Value (T, Small_Val); - Set_Delta_Value (T, Delta_Val); - Set_Is_Constrained (T); + Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Init_Size_Align (T); + Inherit_Rep_Item_Chain (T, Implicit_Base); + Set_Small_Value (T, Small_Val); + Set_Delta_Value (T, Delta_Val); + Set_Is_Constrained (T); end Ordinary_Fixed_Point_Type_Declaration; ---------------------------------- @@ -19090,7 +19095,6 @@ package body Sem_Ch3 is -- ELSE. else - -- In formal mode, when completing a private extension the type -- named in the private part must be exactly the same as that -- named in the visible part. @@ -21215,23 +21219,24 @@ package body Sem_Ch3 is end if; end if; - -- Complete both implicit base and declared first subtype entities + -- Complete both implicit base and declared first subtype entities. The + -- inheritance of the rep item chain ensures that SPARK-related pragmas + -- are not clobbered when the signed integer type acts as a full view of + -- a private type. Set_Etype (Implicit_Base, Base_Typ); - Set_Size_Info (Implicit_Base, (Base_Typ)); + Set_Size_Info (Implicit_Base, Base_Typ); Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - Set_Ekind (T, E_Signed_Integer_Subtype); - Set_Etype (T, Implicit_Base); - - Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - - Set_Size_Info (T, (Implicit_Base)); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Scalar_Range (T, Def); - Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); - Set_Is_Constrained (T); + Set_Ekind (T, E_Signed_Integer_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Inherit_Rep_Item_Chain (T, Implicit_Base); + Set_Scalar_Range (T, Def); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Is_Constrained (T); end Signed_Integer_Type_Declaration; end Sem_Ch3; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index be1b321b253..7914fe1e11b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7617,6 +7617,17 @@ package body Sem_Ch4 is Rewrite (First_Actual, Obj); end if; + -- The operation is obtained from the dispatch table and not by + -- visibility, and may be declared in a unit that is not explicitly + -- referenced in the source, but is nevertheless required in the + -- context of the current unit. Indicate that operation and its scope + -- are referenced, to prevent spurious and misleading warnings. If + -- the operation is overloaded, all primitives are in the same scope + -- and we can use any of them. + + Set_Referenced (Entity (Subprog), True); + Set_Referenced (Scope (Entity (Subprog)), True); + Rewrite (Node_To_Replace, Call_Node); -- Propagate the interpretations collected in subprog to the new diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8940d825704..2466e87cbba 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -454,24 +454,20 @@ package body Sem_Ch6 is Analyze (N); - -- Within a generic we only need to analyze the expression. The body - -- only needs to be constructed when generating code. + -- Within a generic pre-analyze the original expression for name + -- capture. The body is also generated but plays no role in + -- this because it is not part of the original source. if Inside_A_Generic then declare Id : constant Entity_Id := Defining_Entity (N); - Save_In_Spec_Expression : constant Boolean - := In_Spec_Expression; begin Set_Has_Completion (Id); - In_Spec_Expression := True; Push_Scope (Id); Install_Formals (Id); - Preanalyze_And_Resolve (Expr, Etype (Id)); + Preanalyze_Spec_Expression (Expr, Etype (Id)); End_Scope; - In_Spec_Expression := Save_In_Spec_Expression; - return; end; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 43db1c74cf1..1922d5eca9c 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5737,7 +5737,17 @@ package body Sem_Eval is -- same base type. if Has_Discriminants (T1) /= Has_Discriminants (T2) then - if In_Instance then + -- A generic actual type is declared through a subtype declaration + -- and may have an inconsistent indication of the presence of + -- discriminants, so check the type it renames. + + if Is_Generic_Actual_Type (T1) + and then not Has_Discriminants (Etype (T1)) + and then not Has_Discriminants (T2) + then + return True; + + elsif In_Instance then if Is_Private_Type (T2) and then Present (Full_View (T2)) and then Has_Discriminants (Full_View (T2)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4b00be0f3fc..09f80949c4c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9290,6 +9290,37 @@ package body Sem_Util is end if; end Inherit_Default_Init_Cond_Procedure; + ---------------------------- + -- Inherit_Rep_Item_Chain -- + ---------------------------- + + procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is + From_Item : constant Node_Id := First_Rep_Item (From_Typ); + Item : Node_Id; + + begin + -- Reach the end of the destination type's chain (if any). The traversal + -- ensures that we do not go past the last item. + + Item := First_Rep_Item (Typ); + while Present (Item) and then Present (Next_Rep_Item (Item)) loop + Item := Next_Rep_Item (Item); + end loop; + + -- When the destination type has a rep item chain, the chain of the + -- source type is appended to it. + + if Present (Item) then + Set_Next_Rep_Item (Item, From_Item); + + -- Otherwise the destination type directly inherits the rep item chain + -- of the source type. + + else + Set_First_Rep_Item (Typ, From_Item); + end if; + end Inherit_Rep_Item_Chain; + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2892916c757..4ddbe615762 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1083,6 +1083,10 @@ package Sem_Util is -- Inherit the default initial condition procedure from the parent type of -- derived type Typ. + procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id); + -- Inherit the rep item chain of type From_Typ without clobbering any + -- existing rep items on Typ's chain. Typ is the destination type. + procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the