diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 360 | ||||
| -rw-r--r-- | gcc/ada/accessibility.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 262 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/misc.cc | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.cc | 14 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.cc | 31 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 8 | ||||
| -rw-r--r-- | gcc/ada/gsocket.h | 6 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-calend.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-calend.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-socket.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/s-oscons-tmplt.c | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sysdep.c | 6 |
19 files changed, 770 insertions, 64 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d1b78d4..6f6a782 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,363 @@ +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/misc.cc: Make + diagnostics::context::m_source_printing private. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/trans.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/misc.cc: Update for diagnostic_context becoming + diagnostics::context. + +2025-07-25 Marc Poulhiès <poulhies@adacore.com> + + * gcc-interface/utils.cc (update_pointer_to): Renamed ptr/old_ptr, ref/old_ref. + +2025-07-25 Alexandre Oliva <oliva@adacore.com> + + * s-oscons-tmplt.c (CLOCK_RT_Ada) [__vxworks]: Define to + CLOCK_REALTIME on VxWorks6. + * gsocket.h [__vxworks]: Include strings.h if available. + * sysdep.c [__vxworks]: Likewise. + +2025-07-25 Steve Baird <baird@adacore.com> + + * exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): Do + nothing and simply return if either Ada_Version <= Ada_95 or if + the function being returned from lacks the extra formal parameter + needed to perform the check (typically because the result is + tagged). + +2025-07-25 Bob Duff <duff@adacore.com> + + * sem_ch12.adb (Check_Formal_Package_Instance): + Do nothing in case of E_Subprogram_Body. + +2025-07-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Discriminants): Update comments + +2025-07-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Set flag appropriately. + +2025-07-25 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-calend.adb (To_Struct_Timespec_64): Deal with negative + Duration values and truncate the nanoseconds too. + * libgnat/g-calend.adb (timeval_to_duration): Unsuppress overflow + checks. + (duration_to_timeval): Likewise. Deal with negative Duration values + as well as integral Duration values. + * libgnat/g-socket.adb (To_Timeval): Simplify the implementation. + +2025-07-24 Steve Baird <baird@adacore.com> + + * exp_aggr.adb (Convert_To_Assignments): Add calls to Ensure_Defined + before generating assignments to components that could be + associated with a not-yet-defined itype. + +2025-07-24 Steve Baird <baird@adacore.com> + + * accessibility.adb (Function_Call_Or_Allocator_Level): Handle the + case where a function that has an Extra_Accessibility_Of_Result + parameter returns as its result a call to another such function. + In that case, the extra parameter should be passed along. + (Check_Return_Construct_Accessibility): Replace a warning about an + inevitable failure of a dynamic check with a legality-rule-violation + error message; adjust the text of the message accordingly. + * exp_ch6.ads (Apply_Access_Discrims_Accessibility_Check): New + procedure, following example of the existing + Apply_CW_Accessibility procedure. + * exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): body + for new procedure. + (Expand_Simple_Function_Return): Add call to new + Apply_Access_Discrims_Accessibility_Check procedure. + * exp_ch3.adb (Make_Allocator_For_Return): Add call to new + Apply_Access_Discrims_Accessibility_Check procedure. + +2025-07-24 Tonu Naks <naks@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + clarify parameter description. + * gnat_rm.texi: Regenerate. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * sem_ch8.adb (End_Use_Type): Add a test for there not being an earlier + use_type_clause for the same type as an additional criterion for turning + off In_Use and Current_Use_Clause. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Eval_Attribute): Only fold array attributes when prefix + is static or at least safe to evaluate + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * einfo.ads (Is_Controlled_Active): Fix pasto in comment. + * sem_util.ads (Propagate_Controlled_Flags): Update comment for + Destructor aspect. + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: Document new extension. + * snames.ads-tmpl: Add name for new aspect. + * gen_il-fields.ads (Has_Destructor, Is_Destructor): Add new fields. + * gen_il-gen-gen_entities.adb (E_Procedure, Type_Kind): Add new fields. + * einfo.ads (Has_Destructor, Is_Destructor): Document new fields. + * aspects.ads: Add new aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications, + Check_Aspect_At_Freeze_Point, Check_Aspect_At_End_Of_Declarations): + Add semantic analysis for new aspect. + (Resolve_Finalization_Procedure): New function. + (Resolve_Finalizable_Argument): Use new function above. + * sem_util.adb (Propagate_Controlled_Flags): Extend for new field. + * freeze.adb (Freeze_Entity): Add legality check for new aspect. + * exp_ch3.adb (Expand_Freeze_Record_Type, Predefined_Primitive_Bodies): + Use new field. + * exp_ch7.adb (Build_Finalize_Statements): Add expansion for + destructors. + (Make_Final_Call, Build_Record_Deep_Procs): Adapt to new Has_Destructor + field. + (Build_Adjust_Statements): Tweak to handle cases of empty lists. + * gnat_rm.texi: Regenerate. + +2025-07-22 Denis Mazzucato <mazzucato@adacore.com> + + * sem_ch6.adb (Might_Need_BIP_Task_Actuals): Before retrieving the original corresponding + operation we retrieve first the root of the aliased chain. + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * gen_il-fields.ads (Is_Implicit_Full_View): New field. + * gen_il-gen-gen_entities.adb (Type_Kind): Use new field. + * einfo.ads (Is_Implicit_Full_View): Document new field. + * exp_ch7.adb (Make_Adjust_Call, Make_Init_Call, Make_Final_Call): Use + new field. + * exp_util.adb (Finalize_Address): Likewise. + * sem_ch3.adb (Copy_And_Build): Set new field. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (May_Generate_Large_Temp): Delete. + * exp_util.adb (May_Generate_Large_Temp): Likewise. + (Safe_Unchecked_Type_Conversion): Do not take stack checking into + account to compute the result. + +2025-07-22 Javier Miranda <miranda@adacore.com> + + * sinfo.ads (Is_Expanded_Dispatching_Call): New flag. + (Tag_Propagated): New flag. + * exp_ch6.adb (Expand_Call_Helper): Propagate the tag when + the dispatching call is placed in conditionl expressions or + case-expressions. + * sem_ch5.adb (Analyze_Assignment): For assignment of tag- + indeterminate expression, do not propagate the tag if + previously done. + * sem_disp.adb (Is_Tag_Indeterminate): Add missing support + for conditional expression and case expression. + * exp_disp.ads (Is_Expanded_Dispatching_Call): Removed. Function + replaced by a new flag in the nodes. + * exp_disp.adb (Expand_Dispatching_Call): Set a flag in the + call node to remember that the call has been expanded. + (Is_Expanded_Dispatching_Call): Function removed. + * gen_il-fields.ads (Tag_Propagated): New flag. + (Is_Expanded_Dispatching_Call): New flag. + * gen_il-gen-gen_nodes.adb (Tag_Propagated): New flag. + (Is_Expanded_Dispatching_Call): New flag. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * libgnat/a-cbhama.ads (Empty): Add missing default to Capacity formal. + * libgnat/a-cbhama.adb (Empty): Add missing default to Capacity formal. + * exp_aggr.adb (Build_Size_Expr): Test for presence of Capacity + discriminant as additional criterion for generating the call to + the Length function. Update comments. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Safe_Unchecked_Type_Conversion): Always return True + if the expression is the prefix of an N_Selected_Component. + +2025-07-22 Denis Mazzucato <mazzucato@adacore.com> + + * sem_ch6.adb (Might_Need_BIP_Task_Actuals): Check whether No_Task_Parts is enabled in any + of the derived types, or interfaces, from the user-defined primitive return type. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add No_Task_Parts and No_Controlled_Parts to + the representation chain to be visible in the full view of private types. + * aspects.ads (Nonoverridable_Aspect_Id): As per GNAT RM, No_Task_Parts is nonoverridable. + * sem_util.adb (Check_Inherited_Nonoverridable_Aspects): Likewise. + * sem_util.ads: Fix typo and style. + * sem_disp.adb: Missing comment. + +2025-07-22 Javier Miranda <miranda@adacore.com> + + * einfo.ads (Extra_Formals): Complete documentation. + (Has_First_Controlling_Parameter_Aspect): Place it in alphabetical order. + (Has_Frozen_Extra_Formals): New attribute. + * gen_il-fields.ads (Has_Frozen_Extra_Formals): New entity field. + * gen_il-gen-gen_entities.adb (Has_Frozen_Extra_Formals): Adding new + entity flag to subprograms, subprogram types, and and entries. + * gen_il-internals.adb (Image): Adding Has_Frozen_Extra_Formals. + * exp_ch3.adb (Build_Array_Init_Proc): Freeze its extra formals. + (Build_Init_Procedure): Freeze its extra formals. + (Expand_Freeze_Record_Type): For tagged types with foreign convention + create the extra formals of primitives with convention Ada. + * exp_ch6.ads (Create_Extra_Actuals): New subprogram. + * exp_ch6.adb (Check_BIP_Actuals): Adding assertions. + (Create_Extra_Actuals): New subprogram that factorizes code from + Expand_Call_Helper. + (Expand_Call_Helper): Adding support to defer the addition of extra + actuals. Move the code that adds the extra actuals to a new subprogram. + (Is_Unchecked_Union_Equality): Renamed as Is_Unchecked_Union_Predefined_ + Equality_Call. + * exp_ch7.adb (Create_Finalizer): Freeze its extra formals. + (Wrap_Transient_Expression): Link the temporary with its relocated + expression to facilitate locating the expression in the expanded code. + * exp_ch9.ads (Expand_N_Entry_Declaration): Adding one formal. + * exp_ch9.adb (Expand_N_Entry_Declaration): Defer the expansion of + the entry if the extra formals are not available; analyze the built + declarations for the record type that holds all the parameters if + the expansion of the entry declaration was deferred. + * exp_disp.adb (Expand_Dispatching_Call): Handle deferred extra formals. + (Set_CPP_Constructors): Freeze its extra formals. + * freeze.adb (Freeze_Entity): Create the extra actuals of acccess to + subprograms whose designated type is a subprogram type. + (Freeze_Subprogram): Adjust assertion to support deferred extra formals, + and freeze extra formals of non-dispatching subprograms with foreign + convention. Added assertion to check matching of formals in thunks. + * sem_aux.adb (Get_Called_Entity): Adding documentation. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Create the extra formals + of deferred subprograms, subprogram types and entries; create also the + extra actuals of deferred calls. + * sem_ch6.ads (Freeze_Extra_Formals): New subprogram. + (Deferred_Extra_Formals_Support): New package. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Create the extra formals + of subprograms without separate spec. + (Add_Extra_Formal): Add documentation. + (Has_Extra_Formals): Removed. + (Parent_Subprogram): Adding documentation. + (Create_Extra_Formals): Defer adding extra formals if the underlying_type + of some formal type or return type is not available. + (Extra_Formals_Match_OK): Add missing check on the extra formals of + unchecked unions. + (Freeze_Extra_Formals): New subprogram. + (Deferred_Extra_Formals_Support): New package. + * sem_ch9.adb (Analyze_Entry_Declaration): Freeze its extra formals. + * sem_ch13.adb (New_Put_Image_Subprogram): ditto. + * sem_util.ads (Is_Unchecked_Union_Equality): New subprogram. + * sem_util.adb (Is_Unchecked_Union_Equality): ditto. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Get_Actual_Subtype): Do the same for GCC and GNATprove + backends. + +2025-07-22 Martin Clochard <clochard@adacore.com> + + * exp_spark.adb (Expand_SPARK): Add expansion of continue statements. + (Expand_SPARK_N_Continue_Statement): Expand continue statements resolved + as procedure calls into said procedure calls. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Call): Look at the base type of actual parameter + when checking call to Set_Handler. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Get_Actual_Subtype): Only create a new subtype when + the expander is active. Remove a useless test of type inequality, + as well as a useless call to Set_Has_Delayed_Freeze on the subtype. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Size_Expr): Change test of "not Present (...)" + to "No (...)". + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Size_Expr): Determine the length of a container + aggregate association in the case where it's an iteration over an + object of a container type coming from an instantiation of a predefined + container generic. Minor updates to existing comments. + +2025-07-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_util.adb (Finalize_Address): Prevent infinite loop + +2025-07-22 Steve Baird <baird@adacore.com> + + * sem_aux.ads: Declare new function Unique_Component_Name. + * sem_aux.adb: Implement new function Unique_Component_Name. + +2025-07-22 Viljar Indus <indus@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): + Ensure the Expression_Copy always has a parent before + calling any analyze. + +2025-07-22 Steve Baird <baird@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code.Gen_Assign): In the case of + an aggregate component where the component type is mutably tagged + and the component value is provided by a qualified aggregate (and + qualified with a specific type), avoid incorrectly rejecting the + inner aggregate for violating the rule that the type of an + aggregate shall not be class-wide. + * exp_attr.adb: For a predefined streaming operation (i.e., Read, + Write, Input, or Output) of a class-wide type, the external name + of the tag of the value is normally written out by Output and read + in by Input. In the case of a mutably tagged type, this is instead + done in Write and Read. + * exp_ch4.adb (Expand_Composite_Equality): In the case of an + equality comparison for a type having a mutably tagged component, + we want the component comparison to compare two values of the + mutably tagged type, not two values of the corresponding + array-of-bytes-ish representation type. Even if there are no + user-defined equality functions anywhere in sight, comparing the + array values still doesn't work because undefined bits may end up + participating in the comparison (resulting in an incorrect result + of False). + * exp_put_image.adb: In the case of a class-wide type, the + predefined Image attribute includes the name of the specific type + (and a "'" character, to follow qualified expression syntax) to + indicate the tag of the value. With the introduction of mutably + tagged types, this case can now arise in the case of a component + (of either an enclosing array or an enclosing record), not just + for a top-level object. So we factor the code to do this into a + new procedure, Put_Specific_Type_Name_Qualifier, so that it can be + called from more than one place. This reorganization also involves + replacing the procedure Put_String_Exp with a new procedure, + Put_String_Exp_To_Buffer, declared in a less nested scope. For + mutably tagged components (at the source level) the component type + (at the GNAT tree level) is an array of bytes (actually a two + field record containing an array of bytes, but that's a detail). + Appropriate conversions need to be generated so that we don't end + up generating an image for an array of bytes; this is done at the + same places where Put_Specific_Type_Name_Qualifier is called + (for components) by calling Make_Mutably_Tagged_Conversion. + * exp_strm.adb (Make_Field_Attribute): Add + Make_Mutably_Tagged_Conversion call where we construct a + Selected_Component node and the corresponding component type is + the internal representation type for a mutably tagged type. + (Stream_Base_Type): Return the mutably + tagged type if given the corresponding internal representation type. + * sem_ch3.adb (Array_Type_Declaration): In the case where the + source-level component type of an array type is mutably tagged, + set the Component_Type field of the base type of the declared + array type (as opposed to that of the first subtype of the array + type) to the corresponding internal representation type. + * sem_ch4.adb (Analyze_Selected_Component): In the case of a + selected component name which references a component whose type is + the internal representation type of a mutably tagged type, + generate a conversion to the mutably tagged type. + 2025-07-21 Eric Botcazou <ebotcazou@gcc.gnu.org> PR ada/121184 diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 0b8d3f7..c780054 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -327,8 +327,23 @@ package body Accessibility is if In_Return_Value (N) or else In_Return_Context then - return Make_Level_Literal - (Subprogram_Access_Level (Current_Subprogram)); + if Present (Extra_Accessibility_Of_Result + (Current_Subprogram)) + then + -- If a function is passed an extra "level of the + -- master of the call" parameter and that function + -- returns a call to another such function (or + -- possibly to the same function, in the case of a + -- recursive call), then that parameter should be + -- "passed along". + + return New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Current_Subprogram), Loc); + else + return Make_Level_Literal + (Subprogram_Access_Level (Current_Subprogram)); + end if; end if; end if; @@ -1683,16 +1698,14 @@ package body Accessibility is Condition => Check_Cond, Reason => PE_Accessibility_Check_Failed)); - -- If constant folding has happened on the condition for the - -- generated error, then warn about it being unconditional when - -- we know an error will be raised. + -- ??? Is this how we want to detect RM 6.5(5.9) violations? if Nkind (Check_Cond) = N_Identifier and then Entity (Check_Cond) = Standard_True then Error_Msg_N - ("access discriminant in return object could be a dangling" - & " reference??", Return_Stmt); + ("level of type of access discriminant value of return object" + & " is statically too deep", Return_Stmt); end if; end if; diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index 0e9162a..1f0aa03 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -333,9 +333,9 @@ must define with the following profile: "__gnat_last_chance_handler"); -The parameter is a C null-terminated string representing a message to be -associated with the exception (typically the source location of the raise -statement generated by the compiler). The Line parameter when nonzero +The ``Source_Location`` parameter is a C null-terminated string representing a +message to be associated with the exception (typically the source location of +the raise statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. No_Exception_Propagation diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9458bde..cd98369 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4349,6 +4349,7 @@ package body Exp_Aggr is and then Is_Limited_Type (Typ) then Target_Expr := New_Copy_Tree (Name (Parent_Node)); + Ensure_Defined (Typ, Parent_Node); Insert_Actions (Parent_Node, Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent_Node, Make_Null_Statement (Loc)); @@ -4374,6 +4375,7 @@ package body Exp_Aggr is if Nkind (N) in N_Aggregate | N_Extension_Aggregate then Target_Expr := New_Copy_Tree (Lhs); + Ensure_Defined (Typ, Parent_Node); Insert_Actions (Parent_Node, Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent_Node, Make_Null_Statement (Loc)); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5bb4a25..6cf7c9c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7501,6 +7501,12 @@ package body Exp_Ch3 is Apply_CW_Accessibility_Check (Expr, Func_Id); end if; + if Has_Anonymous_Access_Discriminant (Etype (Expr)) then + -- Check that access discrims do not designate entities + -- that the function result could outlive. + Apply_Access_Discrims_Accessibility_Check (Expr, Func_Id); + end if; + Alloc_Expr := New_Copy_Tree (Expr); if Etype (Alloc_Expr) /= Alloc_Typ then @@ -9059,6 +9065,10 @@ package body Exp_Ch3 is if Is_Class_Wide_Type (Etype (Func_Id)) then Apply_CW_Accessibility_Check (Expr_Q, Func_Id); end if; + + -- ??? Usually calls to Apply_CW_Accessibility_Check and to + -- Apply_Access_Discrims_Accessibility_Check come in pairs. + -- Do we need a (conditional) call here to A_A_D_A_C ? end; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1195582..eb7422c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -734,6 +734,258 @@ package body Exp_Ch6 is Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); end Add_Task_Actuals_To_Build_In_Place_Call; + ---------------------------------------------- + -- Apply_Access_Discrims_Accesibility_Check -- + ---------------------------------------------- + + procedure Apply_Access_Discrims_Accessibility_Check + (Exp : Node_Id; Func : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Exp); + + -- Some of the code here in this procedure may need to be factored + -- out at some point because it seems like some of the same + -- functionality would be needed for accessibility checking of a + -- return statement when the function result type is an anonymous + -- access type (as opposed to a type that has an anonymous access + -- discriminant). + -- + -- Another case that is not addressed today is the case where + -- we need to check an access discriminant subcomponent of the + -- function result other than a discriminant of the function result. + -- This can only happen if the function result type has an unconstrained + -- subcomponent subtype that has an access discriminant (which implies + -- that the function result type must be limited). + -- + -- A further corner case of that corner case arises if the limited + -- function result type is class-wide and it is not known statically + -- that this access-discriminant-bearing subcomponent exists. The + -- easiest way to address this properly would probably involve adding + -- a new compiler-generated dispatching procedure; a dispatching call + -- could then be used to perform the check in a context where we know + -- statically the specific type of the function result. Finding a + -- less important unimplemented case would be challenging. + + function Constraint_Bearing_Subtype_If_Any + (Exp : Node_Id) return Node_Id; + -- If we can locate a constrained subtype whose constraint applies + -- to Exp, then return that. Otherwise, return Etype (Exp). + + function Discr_Expression + (Typ : Entity_Id; Discr_Index : Positive) return Node_Id; + -- Typ is a constrained discriminated subtype. + -- Return the constraint expression for the indexed discriminant. + + function Has_Level_Tied_To_Explicitly_Aliased_Param + (Constraint_Exp : Node_Id) return Boolean; + -- Constraint_Exp is the value given for an access discriminant + -- in a discriminant constraint for Exp. Return True iff the + -- accessibility of the type of that discriminant of Exp is the level + -- of an explicitly aliased parameter of Func. If true, this indicates + -- that no check should be performed for this discriminant. + + --------------------------------------- + -- Constraint_Bearing_Subtype_If_Any -- + --------------------------------------- + + function Constraint_Bearing_Subtype_If_Any + (Exp : Node_Id) return Entity_Id + is + Result : Entity_Id := Etype (Exp); + begin + if Is_Constrained (Result) then + return Result; + end if; + + -- Look through expansion-generated levels of indirection + -- to find a constrained subtype. Yuck. This comes up in + -- some cases when the unexpanded source returns an aggregate. + + if Nkind (Exp) = N_Explicit_Dereference + and then Nkind (Prefix (Exp)) = N_Identifier + and then Ekind (Entity (Prefix (Exp))) = E_Constant + then + declare + Acc_Const : Entity_Id := Entity (Prefix (Exp)); + Acc_Const_Value : Node_Id := Empty; + begin + -- look through constants initialized to constants + loop + exit when Nkind (Parent (Acc_Const)) /= N_Object_Declaration; + + Acc_Const_Value := Expression (Parent (Acc_Const)); + + if Nkind (Acc_Const_Value) = N_Identifier + and then Ekind (Entity (Acc_Const_Value)) = E_Constant + then + Acc_Const := Entity (Acc_Const_Value); + else + exit; + end if; + end loop; + + if Nkind (Acc_Const_Value) = N_Allocator + and then Nkind (Expression (Acc_Const_Value)) + = N_Qualified_Expression + then + Result := + Etype (Expression (Acc_Const_Value)); + end if; + end; + end if; + + if Is_Constrained (Result) then + return Result; + end if; + + -- no constrained subtype found + return Etype (Exp); + end Constraint_Bearing_Subtype_If_Any; + + ---------------------- + -- Discr_Expression -- + ---------------------- + + function Discr_Expression + (Typ : Entity_Id; Discr_Index : Positive) return Node_Id + is + Constraint_Elmt : Elmt_Id := + First_Elmt (Discriminant_Constraint (Typ)); + begin + for Skip in 1 .. Discr_Index - 1 loop + Next_Elmt (Constraint_Elmt); + end loop; + return Node (Constraint_Elmt); + end Discr_Expression; + + ------------------------------------------------- + -- Has_Level_Tied_To_Explicitly_Aliased_Param -- + ------------------------------------------------- + + function Has_Level_Tied_To_Explicitly_Aliased_Param + (Constraint_Exp : Node_Id) return Boolean + is + Discr_Exp : Node_Id := Constraint_Exp; + Attr_Prefix : Node_Id; + begin + -- look through constants + while Nkind (Discr_Exp) = N_Identifier + and then Ekind (Entity (Discr_Exp)) = E_Constant + and then Nkind (Parent (Entity (Discr_Exp))) = N_Object_Declaration + loop + Discr_Exp := Expression (Parent (Entity (Discr_Exp))); + end loop; + + if Nkind (Discr_Exp) = N_Attribute_Reference + and then Get_Attribute_Id + (Attribute_Name (Discr_Exp)) = Attribute_Access + then + Attr_Prefix := Ultimate_Prefix (Prefix (Discr_Exp)); + if Is_Entity_Name (Attr_Prefix) + and then Is_Explicitly_Aliased (Entity (Attr_Prefix)) + and then Scope (Entity (Attr_Prefix)) = Func + then + return True; + end if; + end if; + + return False; + end Has_Level_Tied_To_Explicitly_Aliased_Param; + + Discr : Entity_Id := First_Discriminant (Etype (Exp)); + Discr_Index : Positive := 1; + Discr_Exp : Node_Id; + + Constrained_Subtype : constant Entity_Id := + Constraint_Bearing_Subtype_If_Any (Exp); + begin + -- ??? Do not generate a check if version is Ada 95 (or earlier). + -- It is unclear whether this is really correct, or is just a stopgap + -- measure. Investigation is needed to decide how post-Ada-95 binding + -- interpretation changes in RM 3.10.2 should interact with Ada 95's + -- return-by-reference model for functions with limited result types + -- (which was abandoned in Ada 2005). + + if Ada_Version <= Ada_95 then + return; + end if; + + -- If we are returning a function call then that function will + -- perform the needed check. + + if Nkind (Unqualify (Exp)) = N_Function_Call then + return; + end if; + + -- ??? Cope with the consequences of the Disable_Tagged_Cases flag + -- in accessibility.adb (which can cause the extra formal parameter + -- needed for the check(s) generated here to be missing in the case + -- of a tagged result type); this is a workaround and can + -- prevent generation of a required check. + + if No (Extra_Accessibility_Of_Result (Func)) then + return; + end if; + + Remove_Side_Effects (Exp); + + while Present (Discr) loop + if Is_Anonymous_Access_Type (Etype (Discr)) then + if Is_Constrained (Constrained_Subtype) then + Discr_Exp := + New_Copy_Tree + (Discr_Expression (Constrained_Subtype, Discr_Index)); + else + Discr_Exp := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Exp), + Selector_Name => New_Occurrence_Of (Discr, Loc)); + end if; + + if not Has_Level_Tied_To_Explicitly_Aliased_Param (Discr_Exp) then + declare + -- We could do this min operation earlier, as is done + -- for other implicit level parameters. Motivation for + -- doing this min operation (earlier or not) is as for + -- Generate_Minimum_Accessibility (see sem_ch6.adb): + -- if a level value is too big, then the caller and the + -- callee disagree about what it means. + + Level_Of_Master_Of_Call : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Natural, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Make_Integer_Literal (Loc, Scope_Depth (Func)), + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Func), Loc))); + + Discrim_Level : Node_Id; + begin + Analyze (Level_Of_Master_Of_Call); + Analyze (Discr_Exp); + + Discrim_Level := + Accessibility_Level (Discr_Exp, Level => Dynamic_Level); + Analyze (Discrim_Level); + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Discrim_Level, + Right_Opnd => Level_Of_Master_Of_Call), + Reason => PE_Accessibility_Check_Failed), + Suppress => Access_Check); + end; + end if; + end if; + + Next_Discriminant (Discr); + Discr_Index := Discr_Index + 1; + end loop; + end Apply_Access_Discrims_Accessibility_Check; + ---------------------------------- -- Apply_CW_Accessibility_Check -- ---------------------------------- @@ -7317,6 +7569,16 @@ package body Exp_Ch6 is then Apply_CW_Accessibility_Check (Exp, Scope_Id); + -- Check that result's access discrims (if any) do not designate + -- entities that the function result could outlive. See preceding + -- comment about extended return statements and thunks. + + elsif Has_Anonymous_Access_Discriminant (Exp_Typ) + and then not Comes_From_Extended_Return_Statement (N) + and then not Is_Thunk (Scope_Id) + then + Apply_Access_Discrims_Accessibility_Check (Exp, Scope_Id); + -- Ada 2012 (AI05-0073): If the result subtype of the function is -- defined by an access_definition designating a specific tagged -- type T, a check is made that the result value is null or the tag diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 483b78b..5919627 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -105,7 +105,16 @@ package Exp_Ch6 is -- Create the extra actuals of the given call and add them to its -- actual parameters list. + procedure Apply_Access_Discrims_Accessibility_Check + (Exp : Node_Id; Func : Entity_Id); + -- Exp is an expression being returned from a function Func. + -- If the result type of the function has access discriminants, insert + -- checks that the accessibility level of each entity designated by an + -- access discriminant of the result is not deeper than the level of the + -- master of the call. + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); + -- Exp is an expression being returned from a function Func. -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check -- that the level of the return expression's underlying type is not deeper -- than the level of the master enclosing the function. Always generate the diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index 128040e..7711f8b 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -271,7 +271,7 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* No caret by default for Ada. */ if (!OPTION_SET_P (flag_diagnostics_show_caret)) - global_dc->m_source_printing.enabled = false; + global_dc->get_source_printing_options ().enabled = false; /* Copy global settings to local versions. */ gnat_encodings = global_options.x_gnat_encodings; @@ -292,7 +292,7 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* Here is the function to handle the compiler error processing in GCC. */ static void -internal_error_function (diagnostic_context *context, const char *msgid, +internal_error_function (diagnostics::context *context, const char *msgid, va_list *ap) { char *buffer, *p, *loc; diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index cd480ef..fd1d39c 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -1510,7 +1510,7 @@ Pragma_to_gnu (Node_Id gnat_node) const location_t location = input_location; struct cl_option_handlers handlers; unsigned int option_index; - diagnostic_t kind; + enum diagnostics::kind kind; bool imply; gnat_temp = First (Pragma_Argument_Associations (gnat_node)); @@ -1521,12 +1521,12 @@ Pragma_to_gnu (Node_Id gnat_node) switch (id) { case Pragma_Warning_As_Error: - kind = DK_ERROR; + kind = diagnostics::kind::error; imply = false; break; case Pragma_Warnings: - kind = DK_WARNING; + kind = diagnostics::kind::warning; imply = true; break; @@ -1543,11 +1543,11 @@ Pragma_to_gnu (Node_Id gnat_node) switch (Chars (Expression (gnat_temp))) { case Name_Off: - kind = DK_IGNORED; + kind = diagnostics::kind::ignored; break; case Name_On: - kind = DK_WARNING; + kind = diagnostics::kind::warning; break; default: @@ -1569,7 +1569,7 @@ Pragma_to_gnu (Node_Id gnat_node) gnat_expr = Empty; /* For pragma Warnings (Off), we save the current state... */ - if (kind == DK_IGNORED) + if (kind == diagnostics::kind::ignored) diagnostic_push_diagnostics (global_dc, location); /* ...so that, for pragma Warnings (On), we do not enable all @@ -8753,7 +8753,7 @@ gnat_to_gnu (Node_Id gnat_node) /* Set the location information on the result if it's not a simple name or something that contains a simple name, for example a tag, because - we don"t want all the references to get the location of the first use. + we don't want all the references to get the location of the first use. Note that we may have no result if we tried to build a CALL_EXPR node to a procedure with no side-effects and optimization is enabled. */ else if (kind != N_Identifier diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 7324bee..f501915 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -4510,8 +4510,8 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, void update_pointer_to (tree old_type, tree new_type) { - tree ptr = TYPE_POINTER_TO (old_type); - tree ref = TYPE_REFERENCE_TO (old_type); + const tree old_ptr = TYPE_POINTER_TO (old_type); + const tree old_ref = TYPE_REFERENCE_TO (old_type); tree t; /* If this is the main variant, process all the other variants first. */ @@ -4520,7 +4520,7 @@ update_pointer_to (tree old_type, tree new_type) update_pointer_to (t, new_type); /* If no pointers and no references, we are done. */ - if (!ptr && !ref) + if (!old_ptr && !old_ref) return; /* Merge the old type qualifiers in the new type. @@ -4554,12 +4554,13 @@ update_pointer_to (tree old_type, tree new_type) if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) { tree new_ptr, new_ref; + tree ptr, ref; /* If pointer or reference already points to new type, nothing to do. This can happen as update_pointer_to can be invoked multiple times on the same couple of types because of the type variants. */ - if ((ptr && TREE_TYPE (ptr) == new_type) - || (ref && TREE_TYPE (ref) == new_type)) + if ((old_ptr && TREE_TYPE (old_ptr) == new_type) + || (old_ref && TREE_TYPE (old_ref) == new_type)) return; /* Chain PTR and its variants at the end. */ @@ -4568,13 +4569,13 @@ update_pointer_to (tree old_type, tree new_type) { while (TYPE_NEXT_PTR_TO (new_ptr)) new_ptr = TYPE_NEXT_PTR_TO (new_ptr); - TYPE_NEXT_PTR_TO (new_ptr) = ptr; + TYPE_NEXT_PTR_TO (new_ptr) = old_ptr; } else - TYPE_POINTER_TO (new_type) = ptr; + TYPE_POINTER_TO (new_type) = old_ptr; /* Now adjust them. */ - for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) + for (ptr = old_ptr; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t)) { TREE_TYPE (t) = new_type; @@ -4589,13 +4590,13 @@ update_pointer_to (tree old_type, tree new_type) { while (TYPE_NEXT_REF_TO (new_ref)) new_ref = TYPE_NEXT_REF_TO (new_ref); - TYPE_NEXT_REF_TO (new_ref) = ref; + TYPE_NEXT_REF_TO (new_ref) = old_ref; } else - TYPE_REFERENCE_TO (new_type) = ref; + TYPE_REFERENCE_TO (new_type) = old_ref; /* Now adjust them. */ - for (; ref; ref = TYPE_NEXT_REF_TO (ref)) + for (ref = old_ref; ref; ref = TYPE_NEXT_REF_TO (ref)) for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t)) { TREE_TYPE (t) = new_type; @@ -4614,20 +4615,20 @@ update_pointer_to (tree old_type, tree new_type) { tree new_ptr = TYPE_POINTER_TO (new_type); - gcc_assert (TYPE_IS_FAT_POINTER_P (ptr)); + gcc_assert (TYPE_IS_FAT_POINTER_P (old_ptr)); /* If PTR already points to NEW_TYPE, nothing to do. This can happen since update_pointer_to can be invoked multiple times on the same couple of types because of the type variants. */ - if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type) + if (TYPE_UNCONSTRAINED_ARRAY (old_ptr) == new_type) return; update_pointer_to - (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))), + (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (old_ptr))), TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr)))); update_pointer_to - (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))), + (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (old_ptr)))), TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr))))); update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 1ca3ede..5d7bedc 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jul 21, 2025 +GNAT Reference Manual , Jul 24, 2025 AdaCore @@ -13072,9 +13072,9 @@ pragma Export (C, Last_Chance_Handler, "__gnat_last_chance_handler"); @end example -The parameter is a C null-terminated string representing a message to be -associated with the exception (typically the source location of the raise -statement generated by the compiler). The Line parameter when nonzero +The @code{Source_Location} parameter is a C null-terminated string representing a +message to be associated with the exception (typically the source location of +the raise statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 79836e8..5a553d1 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -64,6 +64,12 @@ #include <ioLib.h> #include <hostLib.h> +#if __has_include ("strings.h") +/* On VxWorks6, FD_ZERO uses bzero, but since it's not a standard header, don't + require it. */ +#include "strings.h" +#endif + #define SHUT_RD 0 #define SHUT_WR 1 #define SHUT_RDWR 2 diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb index 4f89a40..0be5673 100644 --- a/gcc/ada/libgnat/a-calend.adb +++ b/gcc/ada/libgnat/a-calend.adb @@ -1068,19 +1068,28 @@ is tv_nsec : out Long_Integer) is pragma Unsuppress (Overflow_Check); - Secs : Duration; - Nano_Secs : Duration; begin - -- Seconds extraction, avoid potential rounding errors - - Secs := D - 0.5; - tv_sec := Long_Long_Integer (Secs); - - -- Nanoseconds extraction + if D = 0.0 then + tv_sec := 0; + tv_nsec := 0; + + elsif D < 0.0 then + tv_sec := Long_Long_Integer (D + 0.5); + if D = Duration (tv_sec) then + tv_nsec := 0; + else + tv_nsec := Long_Integer ((D - Duration (tv_sec)) * Nano + 0.5); + end if; - Nano_Secs := D - Duration (tv_sec); - tv_nsec := Long_Integer (Nano_Secs * Nano); + else + tv_sec := Long_Long_Integer (D - 0.5); + if D = Duration (tv_sec) then + tv_nsec := 0; + else + tv_nsec := Long_Integer ((D - Duration (tv_sec)) * Nano - 0.5); + end if; + end if; end To_Struct_Timespec_64; ------------------ diff --git a/gcc/ada/libgnat/g-calend.adb b/gcc/ada/libgnat/g-calend.adb index e410c3e..a2bc77c 100644 --- a/gcc/ada/libgnat/g-calend.adb +++ b/gcc/ada/libgnat/g-calend.adb @@ -344,6 +344,8 @@ package body GNAT.Calendar is sec : aliased C.Extensions.long_long; usec : aliased C.long; + pragma Unsuppress (Overflow_Check); + begin timeval_to_duration (T, sec'Access, usec'Access); pragma Annotate (CodePeer, Modified, sec); @@ -369,13 +371,28 @@ package body GNAT.Calendar is sec : C.Extensions.long_long; usec : C.long; + pragma Unsuppress (Overflow_Check); + begin if D = 0.0 then sec := 0; usec := 0; + + elsif D < 0.0 then + sec := C.Extensions.long_long (D + 0.5); + if D = Duration (sec) then + usec := 0; + else + usec := C.long ((D - Duration (sec)) * Micro + 0.5); + end if; + else - sec := C.Extensions.long_long (D - 0.5); - usec := C.long ((D - Duration (sec)) * Micro - 0.5); + sec := C.Extensions.long_long (D - 0.5); + if D = Duration (sec) then + usec := 0; + else + usec := C.long ((D - Duration (sec)) * Micro - 0.5); + end if; end if; duration_to_timeval (sec, usec, Result'Access); diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 5042dac..0fed791 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -3059,12 +3059,11 @@ package body GNAT.Sockets is -- Normal case where we do round down else - S := time_t (Val - 0.5); - uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5); - - if uS = -1 then - -- It happen on integer duration + S := time_t (Val - 0.5); + if Val = Timeval_Duration (S) then uS := 0; + else + uS := suseconds_t ((Val - Timeval_Duration (S)) * 1_000_000 - 0.5); end if; end if; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 97537ef..7a5e987 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1976,7 +1976,7 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") #if defined(__linux__) || defined(__FreeBSD__) \ || (defined(_AIX) && defined(_AIXVERSION_530)) \ || defined(__DragonFly__) || defined(__QNX__) \ - || defined (__vxworks) + || (defined (__vxworks) && /* VxWorks7 */ defined (_VSB_CONFIG_FILE)) /** On these platforms use system provided monotonic clock instead of ** the default CLOCK_REALTIME. We then need to set up cond var attributes ** appropriately (see thread.c). @@ -1985,6 +1985,10 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") ** pthread_cond_timedwait (and does not have pthread_condattr_setclock), ** hence the conditionalization on AIX version above). _AIXVERSION_530 ** is defined in AIX 5.3 and more recent versions. + ** + ** VxWorks6 lacks pthread_condattr_setclock, so define CLOCK_RT_Ada to + ** CLOCK_REALTIME to get the dummy definition of __gnat_pthread_condattr_setup + ** in libgnarl/thread.c. **/ # define CLOCK_RT_Ada "CLOCK_MONOTONIC" diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1cb9d115c..b5c9e88 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7574,6 +7574,12 @@ package body Sem_Ch12 is or else not Same_Instantiated_Function (E1, E2)); end if; + -- No check is needed if this is the body of a subprogram that is + -- implicitly created in the case of class-wide predefined functions. + + elsif Ekind (E1) = E_Subprogram_Body then + null; + else raise Program_Error; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 55d2795..3726169 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9660,6 +9660,8 @@ package body Sem_Ch3 is (New_Decl, Parent_Base, New_Base, Is_Completion => False, Derive_Subps => False); + Set_Is_Implicit_Full_View (New_Base); + -- ??? This needs re-examination to determine whether the -- following call can simply be replaced by a call to Analyze. @@ -21293,8 +21295,8 @@ package body Sem_Ch3 is -- On entry, the current scope is the composite type. -- The discriminants are initially entered into the scope of the type - -- via Enter_Name with the default Ekind of E_Void to prevent premature - -- use, as explained at the end of this procedure. + -- via Enter_Name with Is_Not_Self_Hidden set to False to prevent + -- premature use, as explained at the end of this procedure. Discr := First (Discriminant_Specifications (N)); while Present (Discr) loop @@ -21567,12 +21569,12 @@ package body Sem_Ch3 is -- expressions of a discriminant part if the specification of the -- discriminant is itself given in the discriminant part. (RM 3.7.1) - -- To detect this, the discriminant names are entered initially with an - -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any - -- attempt to use a void entity (for example in an expression that is - -- type-checked) produces the error message: premature usage. Now after - -- completing the semantic analysis of the discriminant part, we can set - -- the Ekind of all the discriminants appropriately. + -- To detect this, the discriminant names are entered initially with + -- Is_Not_Self_Hidden set to False. Any attempt to use a self-hidden + -- entity (for example in an expression that is type-checked) produces + -- the error message: premature usage. Now after completing the semantic + -- analysis of the discriminant part, we can set Is_Not_Self_Hidden on + -- all the discriminants appropriately. Discr := First (Discriminant_Specifications (N)); Discr_Number := Uint_1; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 3dc76f9..afbb362 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -40,6 +40,12 @@ - either they are defined as ENOENT (vx7r2); - or the corresponding system includes are not provided (Helix Cert). */ +#if __has_include ("strings.h") +/* On VxWorks6, FD_ZERO uses bzero, and index is also declared in strings.h, + but since it's not a standard header, don't require it. */ +#include "strings.h" +#endif + #if __has_include ("dosFsLib.h") /* On helix-cert, this include is only provided for RTPs. */ #include "dosFsLib.h" |