diff options
| author | Ian Lance Taylor <iant@golang.org> | 2021-10-27 08:47:25 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2021-10-27 08:47:25 -0700 |
| commit | a6d3012b274f38b20e2a57162106f625746af6c6 (patch) | |
| tree | 09ff8b13eb8ff7594c27dc8812efbf696dc97484 /gcc/ada | |
| parent | cd2fd5facb5e1882d3f338ed456ae9536f7c0593 (diff) | |
| parent | 99b1021d21e5812ed01221d8fca8e8a32488a934 (diff) | |
| download | gcc-a6d3012b274f38b20e2a57162106f625746af6c6.zip gcc-a6d3012b274f38b20e2a57162106f625746af6c6.tar.gz gcc-a6d3012b274f38b20e2a57162106f625746af6c6.tar.bz2 | |
Merge from trunk revision 99b1021d21e5812ed01221d8fca8e8a32488a934.
Diffstat (limited to 'gcc/ada')
157 files changed, 6699 insertions, 4175 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index feadd5e..ab7c0f5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,851 @@ +2021-10-25 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in, gcc-interface/Makefile.in: Remove + gnatfind and gnatxref. + +2021-10-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Has_Possible_Literal_Aspects): If analysis of an + operator node fails to find a possible interpretation, and one + of its operands is a literal or a named number, assign to the + node the corresponding class type (Any_Integer, Any_String, + etc). + (Operator_Check): Call it before emitting a type error. + * sem_res.adb (Has_Applicable_User_Defined_Literal): Given a + literal and a type, determine whether the type has a + user_defined aspect that can apply to the literal, and rewrite + the node as call to the corresponding function. Most of the code + was previously in procedure Resolve. + (Try_User_Defined_Literal): Check operands of a predefined + operator that fails to resolve, and apply + Has_Applicable_User_Defined_Literal to literal operands if any, + to find if a conversion will allow the operator to resolve + properly. + (Resolve): Call the above when a literal or an operator with a + literal operand fails to resolve. + +2021-10-25 Bob Duff <duff@adacore.com> + + * freeze.adb (Freeze_Fixed_Point_Type): Remove + previously-inserted test for Uint_0; no longer needed. + * gen_il-gen.ads: Improve comments. + * repinfo.adb (Rep_Value): Use Ubool type for B. + * repinfo.ads (Node_Ref): Use Unegative type. + (Node_Ref_Or_Val): Document that values of this type can be + No_Uint. + * exp_disp.adb (Make_Disp_Requeue_Body): Minor comment fix. + * sem_ch3.adb: Likewise. + * sem_ch8.adb: Likewise. + * sinfo-utils.adb (End_Location): End_Span can never be No_Uint, + so remove the "if No (L)" test. + * uintp.adb (Image_String): Use "for ... of" loop. + * uintp.ads (Unegative): New type for negative integers. We + give it a long name (unlike Unat and Upos) because it is rarely + used. + +2021-10-25 Etienne Servais <servais@adacore.com> + + * errout.adb (Skip_Msg_Insertion_Warning): Adapt and format as + Erroutc.Prescan_Message.Parse_Message_Class. + (Warn_Insertion): Adapt to new format. + * errout.ads: Update documentation. + * erroutc.adb (Get_Warning_Tag): Adapt to new format. + (Prescan_Message): Introduce Parse_Message_Class function. + (Validate_Specific_Warnings): Update ?W? to ?.w?. + * erroutc.ads: Update type and documentation. + * checks.adb (Validity_Check_Range): Update ?X? to ?.x?. + * exp_ch11.adb (Possible_Local_Raise): Update ?X? to ?.x?. + (Warn_If_No_Local_Raise): Likewise. + (Warn_If_No_Propagation): Likewise. + (Warn_No_Exception_Propagation_Active): Likewise. + * exp_ch4.adb (Expand_N_Allocator): Attach warning message to + -gnatw_a. + * exp_prag.adb (Expand_Pragma_Check): Update ?A? to ?.a?. + * exp_util.adb (Activate_Atomic_Synchronization): Update ?N? to + ?.n?. + (Add_Invariant_Check): Update ?L? to ?.l?. + * freeze.adb (Check_Suspicious_Modulus): Update ?M? to ?.m?. + (Freeze_Entity): Update ?T? to ?.t?, ?Z? to ?.z?. + * par-util.adb (Warn_If_Standard_Redefinition): Update ?K? to + ?.k?. + * sem_attr.adb (Min_Max): Update ?U? to ?.u?. + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Update ?V? + to ?.v?. + (Adjust_Record_For_Reverse_Bit_Order_Ada_95): Update ?V? to ?.v?. + (Component_Size_Case): Update ?S? to ?.s?. + (Analyze_Record_Representation_Clause): Update ?S? to ?.s? and + ?C? to ?.c?. + (Add_Call): Update ?L? to ?.l?. + (Component_Order_Check): Attach warning message to -gnatw_r. + (Check_Component_List): Update ?H? to ?.h?. + (Set_Biased): Update ?B? to ?.b?. + * sem_ch3.adb (Modular_Type_Declaration): Update ?M? to ?.m?. + * sem_ch4.adb (Analyze_Mod): Update ?M? to ?.m?. + (Analyze_Quantified_Expression): Update ?T? to ?.t?. + * sem_ch6.adb (Check_Conformance): Attach warning message to + -gnatw_p. + (List_Inherited_Pre_Post_Aspects): Update ?L? to ?.l?. + * sem_ch7.adb (Unit_Requires_Body_Info): Update ?Y? to ?.y?. + * sem_ch8.adb (Analyze_Object_Renaming): Update ?R? to ?.r?. + * sem_prag.adb (Validate_Compile_Time_Warning_Or_Error): Attach + warning message to -gnatw_c. + * sem_res.adb (Check_Argument_Order): Update ?P? to ?.p?. + (Resolve_Comparison_Op): Update ?U? to ?.u?. + (Resolve_Range): Update ?U? to ?.u?. + (Resolve_Short_Circuit): Update ?A? to ?.a?. + (Resolve_Unary_Op): Update ?M? to ?.m?. + * sem_util.adb (Check_Result_And_Post_State): Update ?T? to ?.t?. + * sem_warn.adb (Output_Unused_Warnings_Off_Warnings): Update ?W? + to ?.w?. + * warnsw.ads: Update documentation for -gnatw_c. + +2021-10-25 Bob Duff <duff@adacore.com> + + * inline.adb (Establish_Actual_Mapping_For_Inlined_Call): Fix + comment. + +2021-10-25 Bob Duff <duff@adacore.com> + + * gen_il-gen.adb (Put_Seinfo): Generate type + Seinfo.Type_Only_Enum based on type + Gen_IL.Internals.Type_Only_Enum. Automatically generating a copy + of the type will help keep them in sync. (Note that there are + no Ada compiler packages imported into Gen_IL.) Add a Type_Only + field to Field_Descriptor, so this information is available in + the Ada compiler (as opposed to just in the Gen_IL "compiler"). + (One_Comp): Add initialization of the Type_Only field of + Field_Descriptor. + * gen_il-internals.ads (Image): Image function for + Type_Only_Enum. + * atree.ads (Node_To_Fetch_From): New function to compute which + node to fetch from, based on the Type_Only aspect. + * atree.adb (Get_Field_Value): Call Node_To_Fetch_From. + * treepr.adb (Print_Entity_Field): Call Node_To_Fetch_From. + (Print_Node_Field): Assert. + * sinfo-utils.adb (Walk_Sinfo_Fields, + Walk_Sinfo_Fields_Pairwise): Asserts. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch4.adb (Expand_Composite_Equality): Fix style. + (Element_To_Compare): Simplify loop. + (Expand_Record_Equality): Adapt calls to Element_To_Compare. + +2021-10-25 Steve Baird <baird@adacore.com> + + * sem_case.adb (Composite_Case_Ops.Box_Value_Required): A new + function which takes a component type and returns a Boolean. + Returns True for the cases which were formerly forbidden as + components (these checks were formerly performed in the + now-deleted procedure + Check_Composite_Case_Selector.Check_Component_Subtype). + (Composite_Case_Ops.Normalized_Case_Expr_Type): Hoist this + function out of the Array_Case_Ops package because it has been + generalized to also do the analogous thing in the case of a + discriminated type. + (Composite_Case_Ops.Scalar_Part_Count): Return 0 if + Box_Value_Required returns True for the given type/subtype. + (Composite_Case_Ops.Choice_Analysis.Choice_Analysis.Component_Bounds_Info. + Traverse_Discrete_Parts): Return without doing anything if + Box_Value_Required returns True for the given type/subtype. + (Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice): + If Box_Value_Required yields True for a given component type, + then check that the value of that component in a choice + expression is indeed a box (in which case the component is + ignored). + * doc/gnat_rm/implementation_defined_pragmas.rst: Update + documentation. + * gnat_rm.texi: Regenerate. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-nbnbin__gmp.adb (From_String): Fix predicate + mismatch between subprogram declaration and body. + +2021-10-25 Bob Duff <duff@adacore.com> + + * einfo-utils.adb (Declaration_Node): Avoid returning the + following node kinds: N_Assignment_Statement, N_Integer_Literal, + N_Procedure_Call_Statement, N_Subtype_Indication, and + N_Type_Conversion. Assert that the result is in N_Is_Decl or + empty. + * gen_il-gen-gen_nodes.adb (N_Is_Decl): Modify to match the + things that Declaration_Node can return. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-strsup.ads (Super_Length, Super_Element, + Super_Slice): Add Global contracts. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Predefined_Primitive_Bodies): Simplify detection + of existing equality operator. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Predefined_Primitive_Bodies): Remove redundant + conditions related to interface types. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * adaint.c (__gnat_portable_spawn): Do not expect execv to + return 0. + (__gnat_portable_no_block_spawn): Likewise. + +2021-10-25 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Set New_S to Empty. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-strunb.ads (Unbounded_String): Reference is never + null. + * libgnat/a-strunb.adb (Finalize): Copy reference while it needs + to be deallocated. + +2021-10-25 Piotr Trojanek <trojanek@adacore.com> + + * lib-xref.adb (Get_Through_Renamings): Exit loop when an + enumeration literal is found. + +2021-10-25 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-widthu.adb: Add pragma Annotate. + +2021-10-25 Javier Miranda <miranda@adacore.com> + + * sem_ch8.adb (Build_Class_Wide_Wrapper): Previous version split + in two subprograms to factorize its functionality: + Find_Suitable_Candidate, and Build_Class_Wide_Wrapper. These + routines are also placed in the new subprogram + Handle_Instance_With_Class_Wide_Type. + (Handle_Instance_With_Class_Wide_Type): New subprogram that + encapsulates all the code that handles instantiations with + class-wide types. + (Analyze_Subprogram_Renaming): Adjust code to invoke the new + nested subprogram Handle_Instance_With_Class_Wide_Type; adjust + documentation. + +2021-10-25 Bob Duff <duff@adacore.com> + + * einfo-utils.ads, einfo-utils.adb (Alias, Set_Alias, + Renamed_Entity, Set_Renamed_Entity, Renamed_Object, + Set_Renamed_Object): Add assertions that reflect how these are + supposed to be used and what they are supposed to return. + (Renamed_Entity_Or_Object): New getter. + (Set_Renamed_Object_Of_Possibly_Void): Setter that allows N to + be E_Void. + * checks.adb (Ensure_Valid): Use Renamed_Entity_Or_Object + because this is called for both cases. + * exp_dbug.adb (Debug_Renaming_Declaration): Use + Renamed_Entity_Or_Object because this is called for both cases. + Add assertions. + * exp_util.adb (Possible_Bit_Aligned_Component): Likewise. + * freeze.adb (Freeze_All_Ent): Likewise. + * sem_ch5.adb (Within_Function): Likewise. + * exp_attr.adb (Calculate_Header_Size): Call Renamed_Entity + instead of Renamed_Object. + * exp_ch11.adb (Expand_N_Raise_Statement): Likewise. + * repinfo.adb (Find_Declaration): Likewise. + * sem_ch10.adb (Same_Unit, Process_Spec_Clauses, + Analyze_With_Clause, Install_Parents): Likewise. + * sem_ch12.adb (Build_Local_Package, Needs_Body_Instantiated, + Build_Subprogram_Renaming, Check_Formal_Package_Instance, + Check_Generic_Actuals, In_Enclosing_Instance, + Denotes_Formal_Package, Process_Nested_Formal, + Check_Initialized_Types, Map_Formal_Package_Entities, + Restore_Nested_Formal): Likewise. + * sem_ch6.adb (Report_Conflict): Likewise. + * sem_ch8.adb (Analyze_Exception_Renaming, + Analyze_Generic_Renaming, Analyze_Package_Renaming, + Is_Primitive_Operator_In_Use, Declared_In_Actual, + Note_Redundant_Use): Likewise. + * sem_warn.adb (Find_Package_Renaming): Likewise. + * sem_elab.adb (Ultimate_Variable): Call Renamed_Object instead + of Renamed_Entity. + * exp_ch6.adb (Get_Function_Id): Call + Set_Renamed_Object_Of_Possibly_Void, because the defining + identifer is still E_Void at this point. + * sem_util.adb (Function_Call_Or_Allocator_Level): Likewise. + Remove redundant (unreachable) code. + (Is_Object_Renaming, Is_Valid_Renaming): Call Renamed_Object + instead of Renamed_Entity. + (Get_Fullest_View): Call Renamed_Entity instead of + Renamed_Object. + (Copy_Node_With_Replacement): Call + Set_Renamed_Object_Of_Possibly_Void because the defining entity + is sometimes E_Void. + * exp_ch5.adb (Expand_N_Assignment_Statement): Protect a call to + Renamed_Object with Is_Object to avoid assertion failure. + * einfo.ads: Minor comment fixes. + * inline.adb: Minor comment fixes. + * tbuild.ads: Minor comment fixes. + +2021-10-25 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Build_Discrete_Static_Predicate): Remove use of + exception propagation since this code is exercised during the + bootstrap. + +2021-10-25 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Freeze_Entity_Checks): Perform same check on + predicate expression inside pragma as inside aspect. + * sem_util.adb (Is_Current_Instance): Recognize possible + occurrence of subtype as current instance inside the pragma + Predicate. + +2021-10-25 Ghjuvan Lacambre <lacambre@adacore.com> + + * erroutc.adb (Count_Compile_Time_Pragma_Warnings): Don't count + deleted warnings. + +2021-10-22 Eric Gallager <egallager@gcc.gnu.org> + + PR other/102663 + * gcc-interface/Make-lang.in: Allow dvi-formatted + documentation to be installed. + +2021-10-20 Bob Duff <duff@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Remove unnecessary + call to No_Uint_To_0. + +2021-10-20 Richard Kenner <kenner@adacore.com> + + * exp_unst.adb (Visit_Node, when N_Subprogram_Call): Never treat + instrinsic subprograms as nested. + +2021-10-20 Yannick Moy <moy@adacore.com> + + * libgnat/s-widlllu.ads: Mark in SPARK. + * libgnat/s-widllu.ads: Likewise. + * libgnat/s-widuns.ads: Likewise. + * libgnat/s-widthu.adb: Add ghost code and a + pseudo-postcondition. + +2021-10-20 Yannick Moy <moy@adacore.com> + + * libgnat/a-nbnbin__ghost.adb (Signed_Conversions, + Unsigned_Conversions): Mark subprograms as not imported. + * libgnat/a-nbnbin__ghost.ads: Provide a dummy body. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_eval.adb (Eval_Type_Conversion): If the target subtype is + a static floating-point subtype and the result is a real literal, + consider its machine-rounded value to raise Constraint_Error. + (Test_In_Range): Turn local variables into constants. + +2021-10-20 Doug Rupp <rupp@adacore.com> + + * libgnat/g-io-put__vxworks.adb: Remove (unused) + * libgnat/s-parame__ae653.ads: Likewise. + * libgnat/s-thread.ads: Likewise. + * libgnat/s-thread__ae653.adb: Likewise. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_eval.ads (Machine_Number): New inline function. + * sem_eval.adb (Machine_Number): New function body implementing + the machine rounding operation specified by RM 4.9(38/2). + (Check_Non_Static_Context): Call Machine_Number and set the + Is_Machine_Number flag consistently on the resulting node. + * sem_attr.adb (Eval_Attribute) <Attribute_Machine>: Likewise. + * checks.adb (Apply_Float_Conversion_Check): Call Machine_Number. + (Round_Machine): Likewise. + +2021-10-20 Johannes Kliemann <kliemann@adacore.com> + + * vxworks7-cert-rtp-link.spec: Add the definition of + __wrs_rtp_base. + +2021-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Delta_Record_Aggregate): Reject boxes in + record delta aggregates. + +2021-10-20 Justin Squirek <squirek@adacore.com> + + * sem_ch6.adb (Check_Return_Construct_Accessibility): Modify + generation of accessibility checks to be more consolidated and + get triggered properly in required cases. + * sem_util.adb (Accessibility_Level): Add extra check within + condition to handle aliased formals properly in more cases. + +2021-10-20 Justin Squirek <squirek@adacore.com> + + * exp_ch7.adb (Make_Final_Call): Detect expanded protected types + and use original protected type in order to calculate + appropriate finalization routine. + +2021-10-20 Johannes Kliemann <kliemann@adacore.com> + + * libgnat/a-nbnbin__ghost.ads: Add ghost package. + +2021-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Variant_Depth): Refine type from Integer to + Natural. + +2021-10-20 Bob Duff <duff@adacore.com> + + * atree.ads: Comment improvements. How is a "completely new + node" different from a "new node"? Document default values + corresponding to field types. + * exp_ch7.adb (Process_Tagged_Type_Declaration): Use + higher-level Scope_Depth instead of Scope_Depth_Value. Remove + confusing comment: not clear what a "true" library level package + is. + * uintp.adb (Image_Out): Print No_Uint in a more readable way. + * gen_il-gen.adb, gen_il-gen-gen_entities.adb, + gen_il-gen-gen_nodes.adb, gen_il-types.ads: Tighten up the + subtypes of fields whose type is Uint, where possible; use + more-constrained subtypes such as Unat. + * einfo-utils.adb, einfo-utils.ads, exp_attr.adb, + exp_ch3.adb, exp_intr.adb, exp_unst.adb, exp_util.adb, + freeze.adb, repinfo.adb, sem.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch8.adb, sem_util.adb, sprint.adb, treepr.adb: + No longer use Uint_0 to indicate "unknown" or "not yet known" + for various fields whose type is Uint. Use No_Uint for that, + except in a small number of legacy cases that cause test + failures. Protect many queries of such fields with calls to + Known_... functions. Improve comments. + * exp_aggr.adb: Likewise. + (Is_OK_Aggregate): Check whether Csiz is present. + (Aggr_Assignment_OK_For_Backend): Ensure we do not access an + uninitialized size. + * exp_strm.adb (Build_Elementary_Input_Call, + Build_Elementary_Write_Call): Check whether P_Size is present. + * cstand.adb: Leave Component_Size of Any_Composite unknown. + Similar for RM_Size of Standard_Exception_Type. These should + not be used. + * einfo.ads: Comment improvements. + * exp_disp.ads: Minor. + * gen_il-internals.ads, gen_il-internals.adb: Minor. + * sinfo-utils.adb: Take advantage of full-coverage rules. + * types.h: Minor. + +2021-10-20 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb: Add with and use of Warnsw. + (Check_Conformance): Report a warning when subtypes or + designated subtypes of formal parameters or result subtypes + denote different declarations between the spec and body of the + (Subprogram_Subtypes_Have_Same_Declaration): New function nested + within Check_Conformance that determines whether two subtype + entities referenced in a subprogram come from the same + declaration. Returns True immediately if the subprogram is in a + generic instantiation, or the subprogram is marked Is_Internal + or is declared in an internal (GNAT library) unit, or GNAT_Mode + is enabled, otherwise compares the nonlimited views of the + entities (or their designated subtypes' nonlimited views in the + anonymous access cases). + (Nonlimited_View_Of_Subtype): New function nested within + function Subprogram_Subtypes_Have_Same_Declaration that returns + Non_Limited_View of a type or subtype that is an incomplete or + class-wide type that comes from a limited of a + package (From_Limited_With is True for the entity), or returns + Full_View when the nonlimited view is an incomplete type. + Otherwise returns the entity passed in. + * warnsw.ads (Warn_On_Pedantic_Checks): New warning flag. + (type Warning_Record): New component Warn_On_Pedantic_Checks. + * warnsw.adb (All_Warnings): Set Warn_On_Pedantic_Checks from + parameter Setting. + (Restore_Warnings): Restore the value of the + Warn_On_Pedantic_Checks flag. + (Save_Warnings): Save the value of the Warn_On_Pedantic_Checks + flag. + (Set_Underscore_Warning_Switch): Add settings of the + Warn_On_Pedantic flag according to the switch ("-gnatw_p" vs. + "-gnatw_P"). + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add + documentation of new switches -gnatw_p and -gnatw_P (warnings + for pedantic checks). + * gnat_ugn.texi: Regenerate. + * usage.adb: Add Warn_On_Pedantic_Checks. + +2021-10-20 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Guard + against equality of an uninitialized RM_Size field. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Also propagate an + interface name on an intrinsic subprogram. Remove obsolete comment. + * libgnat/s-atopri.ads (Atomic_Load): New generic intrinsic function + (Atomic_Load_8): Rewrite into instantiation. + (Atomic_Load_16): Likewise. + (Atomic_Load_32): Likewise. + (Atomic_Load_64): Likewise. + (Sync_Compare_And_Swap): New generic intrinsic function. + (Sync_Compare_And_Swap_8): Rewrite into instantiation. + (Sync_Compare_And_Swap_16): Likewise. + (Sync_Compare_And_Swap_32): Likewise. + (Sync_Compare_And_Swap_64): Likewise. + (Lock_Free_Read): New generic inline function. + (Lock_Free_Read_8): Rewrite into instantiation. + (Lock_Free_Read_16): Likewise. + (Lock_Free_Read_32): Likewise. + (Lock_Free_Read_64): Likewise. + (Lock_Free_Try_Write): New generic inline function. + (Lock_Free_Try_Write_8): Rewrite into instantiation. + (Lock_Free_Try_Write_16): Likewise. + (Lock_Free_Try_Write_32): Likewise. + (Lock_Free_Try_Write_64): Likewise. + * libgnat/s-atopri.adb (Lock_Free_Read): New function body. + (Lock_Free_Read_8): Delete. + (Lock_Free_Read_16): Likewise. + (Lock_Free_Read_32): Likewise. + (Lock_Free_Read_64): Likewise. + (Lock_Free_Try_Write): New function body. + (Lock_Free_Try_Write_8): Delete. + (Lock_Free_Try_Write_16): Likewise. + (Lock_Free_Try_Write_32): Likewise. + (Lock_Free_Try_Write_64): Likewise. + * libgnat/s-aoinar.adb (Atomic_Fetch_And_Add): Use type-generic GCC + atomic builtin and tidy up implementation. + (Atomic_Fetch_And_Subtract): Likewise. + * libgnat/s-aomoar.adb (Atomic_Fetch_And_Add): Likewise. + (Atomic_Fetch_And_Subtract): Likewise. + * libgnat/s-atopex.adb (Atomic_Exchange): Likewise. + (Atomic_Compare_And_Exchange): Likewise. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Subprogram_Type>: + Replace test on Convention_Intrinsic with Is_Intrinsic_Subprogram. + (gnat_to_gnu_param): Likewise. + (gnat_to_gnu_subprog_type): Likewise. + * gcc-interface/trans.c (elaborate_all_entities_for_package): Ditto. + +2021-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_eval.ads (Check_Non_Static_Context): Update documentation. + * sem_eval.adb (In_Any_Integer_Context): Change parameter type, + adjust accordingly and remove unreachable case. + (Eval_Integer_Literal): Consider the node kind throughout and + trim down verbose condition. + +2021-10-20 Doug Rupp <rupp@adacore.com> + + * Makefile.rtl: Remove references to system-vxworks-ppc.ads + and system-vxworks-x86.ads. + * libgnat/system-vxworks-ppc.ads: Remove. + * libgnat/system-vxworks-ppc-ravenscar.ads: Likewise. + * libgnat/system-vxworks-x86.ads: Likewise. + +2021-10-20 Yannick Moy <moy@adacore.com> + + * sem_ch4.adb (Analyze_QUantified_Expression): Issue warning on + conjunct/disjunct sub-expression of the full expression inside a + quantified expression, when it does not reference the quantified + variable. + +2021-10-20 Marc Poulhiès <poulhies@adacore.com> + + * checks.adb (Insert_Valid_Check): in case of checked type + conversion, update Typ to match Exp's type and add call to + Analyze_And_Resolve. + +2021-10-20 Arnaud Charlet <charlet@adacore.com> + + PR ada/100486 + * sem_prag.adb (Check_Valid_Library_Unit_Pragma): Do not raise an + exception as part of the bootstrap. + +2021-10-15 Richard Biener <rguenther@suse.de> + + * gcc-interface/misc.c (gnat_post_options): Do not warn + about DBX_DEBUG use here. + +2021-10-14 Alexandre Oliva <oliva@adacore.com> + + * par-ch10.adb (P_Compilation_Unit): Reenable ada83 library + unit renaming test and error. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (resolve_atomic_size): Declare. + (list_third): New inline function. + * gcc-interface/decl.c (type_for_atomic_builtin_p): New function. + (resolve_atomic_builtin): Likewise. + (gnat_to_gnu_subprog_type): Perform type resolution for most of + type-generic GCC atomic builtins and give an error for the rest. + * gcc-interface/utils2.c (resolve_atomic_size): Make public. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (gnat_to_gnu) <N_Pop_Constraint_Error_Label>: + Given the warning only if No_Exception_Propagation is active. + <N_Pop_Storage_Error_Label>: Likewise. + <N_Pop_Program_Error_Label>: Likewise. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (promote_object_alignment): Add GNU_SIZE + parameter and use it for the size of the object if not null. + (gnat_to_gnu_entity) <E_Variable>: Perform the automatic alignment + promotion for objects whose nominal subtype is of variable size. + (gnat_to_gnu_field): Adjust call to promote_object_alignment. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_param): Strip padding types + only if the size does not change in the process. Rename local + variable and add bypass for initialization procedures. + +2021-10-11 Doug Rupp <rupp@adacore.com> + + * libgnat/s-thread.ads: Fix comments. Remove unused package + imports. + (Thread_Body_Exception_Exit): Remove Exception_Occurrence + parameter. + (ATSD): Declare type locally. + * libgnat/s-thread__ae653.adb: Fix comments. Remove unused + package imports. Remove package references to Stack_Limit + checking. + (Install_Handler): Remove. + (Set_Sec_Stack): Likewise. + (Thread_Body_Enter): Remove calls to Install_Handler and + Stack_Limit checking. + (Thread_Body_Exception_Exit): Remove Exception_Occurrence + parameter. + (Init_RTS): Call local Get_Sec_Stack. Remove call to + Install_Handler. Remove references to accessors for + Get_Sec_Stack and Set_Sec_Stack. Remove OS check. + (Set_Sec_Stack): Remove. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Make_Predefined_Primitive_Specs, + Predefined_Primitive_Bodies): Remove guard with restriction + No_Dispatching_Calls. + +2021-10-11 Steve Baird <baird@adacore.com> + + * sem_attr.adb (Analyze_Attribute_Old_Result): Permit an + attribute reference inside a compiler-generated _Postconditions + procedure. In this case, Subp_Decl is assigned the declaration + of the enclosing subprogram. + * exp_util.adb (Insert_Actions): When climbing up the tree + looking for an insertion point, do not climb past an + N_Iterated_Component/Element_Association, since this could + result in inserting a reference to a loop parameter at a + location outside of the scope of that loop parameter. On the + other hand, be careful to preserve existing behavior in the case + of an N_Component_Association node. + +2021-10-11 Steve Baird <baird@adacore.com> + + * exp_ch6.adb (Can_Fold_Predicate_Call): Do not attempt folding + if there is more than one predicate involved. Recall that + predicate aspect specification are additive, not overriding, and + that there are three different predicate + aspects (Dynamic_Predicate, Static_Predicate, and the + GNAT-defined Predicate aspect). These various ways of + introducing multiple predicates are all checked for. A new + nested function, Augments_Other_Dynamic_Predicate, is + introduced. + * sem_ch4.adb + (Analyze_Indexed_Component_Form.Process_Function_Call): When + determining whether a name like "X (Some_Discrete_Type)" might + be interpreted as a slice, the answer should be "no" if the + type/subtype name denotes the current instance of type/subtype. + +2021-10-11 Patrick Bernardi <bernardi@adacore.com> + + * libgnarl/s-osinte__rtems.ads: Change sigset_t to an unsigned + long. + +2021-10-11 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/s-parame__rtems.adb: use + _POSIX_Threads_Minimum_stack_size instead of + ada_pthread_minimum_stack_size. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h (No_Exception_Propagation_Active): Declare. + * restrict.ads (No_Exception_Propagation_Active): Add WARNING line. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Validate_Unchecked_Conversion): Simplify code + for detecting conversions with Ada.Calendar.Time type and extend + it to similar types in the Ada.Real_Time package. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch10.adb, sem_prag.adb, sem_util.adb: Use + N_Generic_Declaration in membership tests. + +2021-10-11 Etienne Servais <servais@adacore.com> + + * ali.adb (Get_Name): Ignore_Spaces is always False. + * bindo-graphs.adb (Set_Is_Existing_Source_Target_Relation): Val + is always True. + * cstand.adb (New_Standard_Entity): New_Node_Kind is always + N_Defininig_Identifier. + * exp_ch3.adb (Predef_Stream_Attr_Spec): For_Body is always + False. + * exp_dist.adb (Add_Parameter_To_NVList): RACW_Ctrl is always + False. + * gnatls.adb (Add_Directories): Prepend is always False. + * sem_ch10.adb, sem_ch10.ads (Load_Needed_Body): Do_Analyze is + always True. + * sem_ch3.adb, sem_ch3.ads (Process_Range_Expr_In_Decl): + R_Check_Off is always False. + * sem_elab.adb: (Info_Variable_Reference): Info_Msg is always + False, In_SPARK is always True. + (Set_Is_Traversed_Body, Set_Is_Saved_Construct, + Set_Is_Saved_Relation): Val is always True. + * treepr.adb (Visit_Descendant): No_Indent is always False. + (Print_Node): Fmt does not need such a big scope. + +2021-10-11 Etienne Servais <servais@adacore.com> + + * sem_ch4.adb (Analyze_Membership_Op): Finds interpretation for + the case of a membership test with a singleton value in case of + overloading. + +2021-10-11 Patrick Bernardi <bernardi@adacore.com> + + * Makefile.rtl (VxWorks): Rename s-inmaop__vxworks.adb to + s-inmaop__hwint.adb. + (RTEMS): Use s-inmaop__hwint.adb, s-intman__rtems.adb/s, + s-taprop__rtems.adb. + * libgnarl/a-intnam__rtems.ads: Remove signals definitions and + replace with Hardware_Interrupts. + * libgnarl/s-inmaop__vxworks.adb: Rename as... + * libgnarl/s-inmaop__hwint.adb: ... this. + * libgnarl/s-interr__hwint.adb: Remove unnecessary comments. + * libgnarl/s-intman__rtems.ads, libgnarl/s-intman__rtems.adb: + New files. + * libgnarl/s-osinte__rtems.adb: Add RTEMS API bindings. + (Binary_Semaphore_Create, Binary_Semaphore_Delete, + Binary_Semaphore_Obtain, Binary_Semaphore_Release, + Binary_Semaphore_Flush, Interrupt_Connect, + Interrupt_Number_To_Vector): New functions. + * libgnarl/s-osinte__rtems.ads (Num_HW_Interrupts, Signal): + Removed. + (NSIG, Interrupt_Range): New. + (Binary_Semaphore_Create, Binary_Semaphore_Delete, + Binary_Semaphore_Obtain, Binary_Semaphore_Release, + Binary_Semaphore_Flush, Interrupt_Connect, + Interrupt_Number_To_Vector): Remove Import pragma. + * libgnarl/s-taprop__rtems.adb: New file. + +2021-10-11 Eric Botcazou <ebotcazou@adacore.com> + + * exp_fixd.adb (Get_Size_For_Value): New function returning a size + suitable for a non-negative integer value. + (Get_Type_For_Size): New function returning a standard type suitable + for a size. + (Build_Divide): Call both functions to compute the result type, but + make sure to pass a non-negative value to the first. + (Build_Multiply): Likewise. + (Do_Multiply_Fixed_Universal): Minor consistency tweak. + (Integer_Literal): Call both functions to compute the type. + +2021-10-11 Etienne Servais <servais@adacore.com> + + * sem_ch4.adb (Analyze_Membership_Op): Reorder subprogram spec + and bodies in alphabetical order. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Build_Class_Wide_Expression): Replace entities + of both simple and extended names. + +2021-10-11 Ghjuvan Lacambre <lacambre@adacore.com> + + * libgnarl/s-intman__android.adb, libgnarl/s-intman__lynxos.adb, + libgnarl/s-intman__posix.adb, libgnarl/s-intman__qnx.adb, + libgnarl/s-intman__solaris.adb, libgnarl/s-intman__susv3.adb, + libgnarl/s-taprob.adb, libgnarl/s-taprop__hpux-dce.adb, + libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb, + libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__qnx.adb, + libgnarl/s-taprop__solaris.adb, libgnarl/s-taprop__vxworks.adb, + libgnarl/s-taskin.adb, libgnarl/s-tasque.adb, + libgnarl/s-tpoben.adb, libgnat/a-calend.adb, + libgnat/a-excach.adb, libgnat/a-except.adb, libgnat/a-tags.adb, + libgnat/a-textio.adb, libgnat/a-witeio.adb, + libgnat/a-ztexio.adb, libgnat/g-binenv.adb, + libgnat/s-parame.adb, libgnat/s-parame__vxworks.adb, + libgnat/s-stratt.adb, libgnat/s-trasym__dwarf.adb: Mark imported + binder globals as constant. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Initialize_Record_Component): Add assertion + about one of the parameters, so that illegal attempts to + initialize record components with Empty node are detected early + on. + (Build_Record_Aggr_Code): Handle boxes in aggregate component + associations just the components with no initialization in + Build_Record_Init_Proc. + * sem_aggr.adb (Resolve_Record_Aggregate): For components that + require simple initialization carry boxes from resolution to + expansion. + * sem_util.adb (Needs_Simple_Initialization): Remove redundant + paren. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Build_Init_Statements): Simplify detection of + concurrent record types. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Is_Delayed_Aggregate): Simplify. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Has_Default_Init_Comps): Simplify. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Component_OK_For_Backend): Remove redundant + guard. + +2021-10-11 Patrick Bernardi <bernardi@adacore.com> + + * Makefile.rtl (RTEMS): Add s-stchop.o to + EXTRA_GNATRTL_NONTASKING_OBJS, remove s-stchop__rtems.adb. + * libgnat/s-stchop__rtems.adb: Removed. + +2021-10-11 Marc Poulhiès <poulhies@adacore.com> + + * expander.adb (Expand): Skip clearing of Analyzed flag if + already set for N_Real_Literal. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Compile_Time_Constraint_Error): Simplify getting + the type of the first formal parameter. + +2021-10-11 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Inside_Init_Proc): Simplify. + * sem_aggr.adb (Resolve_Record_Aggregate): Fix style. + * sem_util.adb (Compile_Time_Constraint_Error): Guard against + calling Corresponding_Concurrent_Type with an array type entity. + +2021-10-11 Doug Rupp <rupp@adacore.com> + + * libgnat/s-parame__ae653.ads (time_t_bits): Change to + Long_Long_Integer'Size. Add some comments to explain. + +2021-10-08 Martin Liska <mliska@suse.cz> + + * gcc-interface/misc.c (gnat_post_options): Use new macro + OPTION_SET_P. + (gnat_init_gcc_eh): Likewise. + (gnat_init_gcc_fp): Likewise. + 2021-10-05 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/trans.c (gnat_to_gnu): Do not wrap boolean values diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index db21f01..ebfbe95 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1084,7 +1084,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ s-dorepr.adb<libgnat/s-dorepr__fma.adb \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ + s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \ s-intman.ads<libgnarl/s-intman__vxworks.ads \ s-intman.adb<libgnarl/s-intman__vxworks.adb \ s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ @@ -1166,9 +1166,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe s-vxwext.ads<libgnarl/s-vxwext__kernel.ads \ s-vxwext.adb<libgnarl/s-vxwext__kernel.adb \ system.ads<libgnat/$(SVX)-$(ARCH_STR)-kernel.ads - else - LIBGNAT_TARGET_PAIRS += \ - system.ads<libgnat/system-vxworks-ppc.ads endif endif EXTRA_GNATRTL_NONTASKING_OBJS+=i-vxinco.o i-vxwork.o i-vxwoio.o @@ -1207,7 +1204,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ + s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \ s-intman.ads<libgnarl/s-intman__vxworks.ads \ s-intman.adb<libgnarl/s-intman__vxworks.adb \ s-osprim.adb<libgnat/s-osprim__posix.adb \ @@ -1315,9 +1312,6 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ s-vxwext.ads<libgnarl/s-vxwext__kernel.ads \ s-vxwext.adb<libgnarl/s-vxwext__kernel.adb \ system.ads<libgnat/$(SVX)-x86-kernel.ads - else - LIBGNAT_TARGET_PAIRS += \ - system.ads<libgnat/system-vxworks-x86.ads endif endif @@ -1351,7 +1345,7 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend a-naliop.ads<libgnat/a-naliop__nolibm.ads \ a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ + s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \ s-interr.adb<libgnarl/s-interr__vxworks.adb \ s-intman.ads<libgnarl/s-intman__vxworks.ads \ s-intman.adb<libgnarl/s-intman__vxworks.adb \ @@ -2047,19 +2041,21 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),) LIBGNAT_TARGET_PAIRS = \ system.ads<libgnat/system-rtems.ads \ a-intnam.ads<libgnarl/a-intnam__rtems.ads \ - s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ - s-intman.adb<libgnarl/s-intman__posix.adb \ + s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \ + s-intman.adb<libgnarl/s-intman__rtems.adb \ + s-intman.ads<libgnarl/s-intman__rtems.ads \ s-osinte.adb<libgnarl/s-osinte__rtems.adb \ s-osinte.ads<libgnarl/s-osinte__rtems.ads \ s-osprim.adb<libgnat/s-osprim__rtems.adb \ s-parame.adb<libgnat/s-parame__rtems.adb \ s-parame.ads<libgnat/s-parame__posix2008.ads \ - s-taprop.adb<libgnarl/s-taprop__posix.adb \ + s-taprop.adb<libgnarl/s-taprop__rtems.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ - s-stchop.adb<libgnat/s-stchop__rtems.adb \ s-interr.adb<libgnarl/s-interr__hwint.adb + EXTRA_GNATRTL_NONTASKING_OBJS += s-stchop.o + ifeq ($(strip $(filter-out arm%, $(target_cpu))),) EH_MECHANISM=-arm else diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 60cfa93..6781728 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2424,8 +2424,10 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED) if (pid == 0) { /* The child. */ - if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) - _exit (1); + execv (args[0], MAYBE_TO_PTR32 (args)); + + /* execv() returns only on error */ + _exit (1); } /* The parent. */ @@ -2822,8 +2824,10 @@ __gnat_portable_no_block_spawn (char *args[] ATTRIBUTE_UNUSED) if (pid == 0) { /* The child. */ - if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) - _exit (1); + execv (args[0], MAYBE_TO_PTR32 (args)); + + /* execv() returns only on error */ + _exit (1); } return pid; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 3815a70..88cc247 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -963,19 +963,18 @@ package body ALI is -- special characters are included in the returned name. function Get_Name - (Ignore_Spaces : Boolean := False; - Ignore_Special : Boolean := False; + (Ignore_Special : Boolean := False; May_Be_Quoted : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to -- all lower case, for systems where file names are not case sensitive. -- This ensures that gnatbind works correctly regardless of the case - -- of the file name on all systems. The termination condition depends - -- on the settings of Ignore_Spaces and Ignore_Special: + -- of the file name on all systems. -- - -- If Ignore_Spaces is False (normal case), then scan is terminated - -- by the normal end of field condition (EOL, space, horizontal tab) + -- The scan is terminated by the normal end of field condition + -- (EOL, space, horizontal tab). Furthermore, the termination condition + -- depends on the setting of Ignore_Special: -- -- If Ignore_Special is False (normal case), the scan is terminated by -- a typeref bracket or an equal sign except for the special case of @@ -986,7 +985,6 @@ package body ALI is -- the name is 'unquoted'. In this case Ignore_Special is ignored and -- assumed to be True. -- - -- It is an error to set both Ignore_Spaces and Ignore_Special to True. -- This function handles wide characters properly. function Get_Nat return Nat; @@ -1240,8 +1238,7 @@ package body ALI is -------------- function Get_Name - (Ignore_Spaces : Boolean := False; - Ignore_Special : Boolean := False; + (Ignore_Special : Boolean := False; May_Be_Quoted : Boolean := False) return Name_Id is Char : Character; @@ -1298,7 +1295,7 @@ package body ALI is loop Add_Char_To_Name_Buffer (Getc); - exit when At_End_Of_Field and then not Ignore_Spaces; + exit when At_End_Of_Field; if not Ignore_Special then if Name_Buffer (1) = '"' then diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 98614e8..88d766a 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -854,14 +854,15 @@ package body Atree is (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit is Desc : Field_Descriptor renames Field_Descriptors (Field); + NN : constant Node_Or_Entity_Id := Node_To_Fetch_From (N, Field); begin case Field_Size (Desc.Kind) is - when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset)); - when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset)); - when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset)); - when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset)); - when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32 + when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (NN, Desc.Offset)); + when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (NN, Desc.Offset)); + when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (NN, Desc.Offset)); + when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (NN, Desc.Offset)); + when others => return Get_32_Bit_Val (NN, Desc.Offset); -- 32 end case; end Get_Field_Value; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2f3ca40..c239507 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -47,6 +47,7 @@ with Alloc; with Sinfo.Nodes; use Sinfo.Nodes; with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; with Types; use Types; with Seinfo; use Seinfo; with System; use System; @@ -230,11 +231,18 @@ package Atree is function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id; - -- Allocates a completely new node with the given node type and source - -- location values. All other fields are set to their standard defaults: + -- Allocates a new node with the given node type and source location + -- values. Fields have defaults depending on their type: + + -- Flag: False + -- Node_Id: Empty + -- List_Id: Empty + -- Elist_Id: No_Elist + -- Uint: No_Uint -- - -- Empty for all FieldN fields - -- False for all FlagN fields + -- Name_Id, String_Id, Valid_Uint, Unat, Upos, Nonzero_Uint, Ureal: + -- No default. This means it is an error to call the getter before + -- calling the setter. -- -- The usual approach is to build a new node using this function and -- then, using the value returned, use the Set_xxx functions to set @@ -288,16 +296,16 @@ package Atree is -- with copying aspect specifications where this is required. function New_Copy (Source : Node_Id) return Node_Id; - -- This function allocates a completely new node, and then initializes - -- it by copying the contents of the source node into it. The contents of - -- the source node is not affected. The target node is always marked as - -- not being in a list (even if the source is a list member), and not - -- overloaded. The new node will have an extension if the source has - -- an extension. New_Copy (Empty) returns Empty, and New_Copy (Error) - -- returns Error. Note that, unlike Copy_Separate_Tree, New_Copy does not - -- recursively copy any descendants, so in general parent pointers are not - -- set correctly for the descendants of the copied node. Both normal and - -- extended nodes (entities) may be copied using New_Copy. + -- This function allocates a new node, and then initializes it by copying + -- the contents of the source node into it. The contents of the source node + -- is not affected. The target node is always marked as not being in a list + -- (even if the source is a list member), and not overloaded. The new node + -- will have an extension if the source has an extension. New_Copy (Empty) + -- returns Empty, and New_Copy (Error) returns Error. Note that, unlike + -- Copy_Separate_Tree, New_Copy does not recursively copy any descendants, + -- so in general parent pointers are not set correctly for the descendants + -- of the copied node. Both normal and extended nodes (entities) may be + -- copied using New_Copy. function Relocate_Node (Source : Node_Id) return Node_Id; -- Source is a non-entity node that is to be relocated. A new node is @@ -340,11 +348,11 @@ package Atree is -- Exchange the contents of two entities. The parent pointers are switched -- as well as the Defining_Identifier fields in the parents, so that the -- entities point correctly to their original parents. The effect is thus - -- to leave the tree completely unchanged in structure, except that the - -- entity ID values of the two entities are interchanged. Neither of the - -- two entities may be list members. Note that entities appear on two - -- semantic chains: Homonym and Next_Entity: the corresponding links must - -- be adjusted by the caller, according to context. + -- to leave the tree unchanged in structure, except that the entity ID + -- values of the two entities are interchanged. Neither of the two entities + -- may be list members. Note that entities appear on two semantic chains: + -- Homonym and Next_Entity: the corresponding links must be adjusted by the + -- caller, according to context. procedure Extend_Node (Source : Node_Id); -- This turns a node into an entity; it function is used only by Sinfo.CN. @@ -609,6 +617,20 @@ package Atree is -- always the same; for example we change from E_Void, to E_Variable, to -- E_Void, to E_Constant. + function Node_To_Fetch_From + (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) + return Node_Or_Entity_Id is + (case Field_Descriptors (Field).Type_Only is + when No_Type_Only => N, + when Base_Type_Only => Base_Type (N), + when Impl_Base_Type_Only => Implementation_Base_Type (N), + when Root_Type_Only => Root_Type (N)); + -- This is analogous to the same-named function in Gen_IL.Gen. Normally, + -- Type_Only is No_Type_Only, and we fetch the field from the node N. But + -- if Type_Only = Base_Type_Only, we need to go to the Base_Type, and + -- similarly for the other two cases. This can return something other + -- than N only if N is an Entity. + ----------------------------- -- Private Part Subpackage -- ----------------------------- diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb index 011b0f4..0989981 100644 --- a/gcc/ada/bindo-graphs.adb +++ b/gcc/ada/bindo-graphs.adb @@ -4903,11 +4903,10 @@ package body Bindo.Graphs is procedure Set_Is_Existing_Source_Target_Relation (G : Invocation_Graph; - Rel : Source_Target_Relation; - Val : Boolean := True); + Rel : Source_Target_Relation); pragma Inline (Set_Is_Existing_Source_Target_Relation); -- Mark a source vertex and a target vertex described by relation Rel as - -- already related in invocation graph G depending on value Val. + -- already related in invocation graph G. procedure Set_IGE_Attributes (G : Invocation_Graph; @@ -5636,19 +5635,14 @@ package body Bindo.Graphs is procedure Set_Is_Existing_Source_Target_Relation (G : Invocation_Graph; - Rel : Source_Target_Relation; - Val : Boolean := True) + Rel : Source_Target_Relation) is begin pragma Assert (Present (G)); pragma Assert (Present (Rel.Source)); pragma Assert (Present (Rel.Target)); - if Val then - Relation_Sets.Insert (G.Relations, Rel); - else - Relation_Sets.Delete (G.Relations, Rel); - end if; + Relation_Sets.Insert (G.Relations, Rel); end Set_Is_Existing_Source_Target_Relation; ------------------------ diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index a58a495..bbccab7 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -847,7 +847,7 @@ package body Checks is else Error_Msg_N ("\address value may be incompatible with alignment of " - & "object?X?", AC); + & "object?.x?", AC); end if; end if; @@ -2171,7 +2171,7 @@ package body Checks is Lo_OK := (Ifirst > 0); else - Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Expr); + Lo := Machine_Number (Expr_Type, UR_From_Uint (Ifirst), Expr); Lo_OK := (Lo >= UR_From_Uint (Ifirst)); end if; @@ -2214,7 +2214,7 @@ package body Checks is Hi := UR_From_Uint (Ilast) + Ureal_Half; Hi_OK := (Ilast < 0); else - Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Expr); + Hi := Machine_Number (Expr_Type, UR_From_Uint (Ilast), Expr); Hi_OK := (Hi <= UR_From_Uint (Ilast)); end if; @@ -5563,7 +5563,7 @@ package body Checks is -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left. function Round_Machine (B : Ureal) return Ureal; - -- B is a real bound. Round it using mode Round_Even. + -- B is a real bound. Round it to the nearest machine number. ----------------- -- OK_Operands -- @@ -5589,7 +5589,7 @@ package body Checks is function Round_Machine (B : Ureal) return Ureal is begin - return Machine (Typ, B, Round_Even, N); + return Machine_Number (Typ, B, N); end Round_Machine; -- Start of processing for Determine_Range_R @@ -6676,8 +6676,9 @@ package body Checks is elsif not Comes_From_Source (Expr) and then not (Nkind (Expr) = N_Identifier - and then Present (Renamed_Object (Entity (Expr))) - and then Comes_From_Source (Renamed_Object (Entity (Expr)))) + and then Present (Renamed_Entity_Or_Object (Entity (Expr))) + and then + Comes_From_Source (Renamed_Entity_Or_Object (Entity (Expr)))) and then not Force_Validity_Checks and then (Nkind (Expr) /= N_Unchecked_Type_Conversion or else Kill_Range_Check (Expr)) @@ -8077,7 +8078,7 @@ package body Checks is Is_High_Bound : Boolean := False) is Loc : constant Source_Ptr := Sloc (Expr); - Typ : constant Entity_Id := Etype (Expr); + Typ : Entity_Id := Etype (Expr); Exp : Node_Id; begin @@ -8137,6 +8138,7 @@ package body Checks is while Nkind (Exp) = N_Type_Conversion loop Exp := Expression (Exp); end loop; + Typ := Etype (Exp); -- Do not generate a check for a variable which already validates the -- value of an assignable object. @@ -8217,6 +8219,14 @@ package body Checks is Set_Do_Range_Check (Validated_Object (Var_Id), False); end if; + -- In case of a type conversion, an expansion of the expr may be + -- needed (eg. fixed-point as actual). + + if Exp /= Expr then + pragma Assert (Nkind (Expr) = N_Type_Conversion); + Analyze_And_Resolve (Expr); + end if; + PV := New_Occurrence_Of (Var_Id, Loc); -- Otherwise the expression does not denote a variable. Force its diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 409944c..3822d93 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -149,8 +149,7 @@ package body CStand is function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id; -- Build entity for standard operator with given name and type - function New_Standard_Entity - (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id; + function New_Standard_Entity return Entity_Id; -- Builds a new entity for Standard function New_Standard_Entity (Nam : String) return Entity_Id; @@ -1234,10 +1233,11 @@ package body CStand is Mutate_Ekind (Any_Composite, E_Array_Type); Set_Scope (Any_Composite, Standard_Standard); Set_Etype (Any_Composite, Any_Composite); - Set_Component_Size (Any_Composite, Uint_0); Set_Component_Type (Any_Composite, Standard_Integer); Reinit_Size_Align (Any_Composite); + pragma Assert (not Known_Component_Size (Any_Composite)); + Any_Discrete := New_Standard_Entity ("a discrete type"); Mutate_Ekind (Any_Discrete, E_Signed_Integer_Type); Set_Scope (Any_Discrete, Standard_Standard); @@ -1509,10 +1509,11 @@ package body CStand is Set_Scope (Standard_Exception_Type, Standard_Standard); Set_Stored_Constraint (Standard_Exception_Type, No_Elist); - Set_RM_Size (Standard_Exception_Type, Uint_0); Set_Size_Known_At_Compile_Time (Standard_Exception_Type, True); + pragma Assert (not Known_RM_Size (Standard_Exception_Type)); + Make_Aliased_Component (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others"); Make_Aliased_Component (Standard_Exception_Type, Standard_Character, @@ -1793,10 +1794,9 @@ package body CStand is -- New_Standard_Entity -- ------------------------- - function New_Standard_Entity - (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id + function New_Standard_Entity return Entity_Id is - E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc); + E : constant Entity_Id := New_Entity (N_Defining_Identifier, Stloc); begin -- All standard entities are Pure and Public diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 0375982..768dd668 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2268,9 +2268,24 @@ of GNAT specific extensions are recognized as follows: set shall be a proper subset of the second (and the later alternative will not be executed if the earlier alternative "matches"). All possible values of the composite type shall be covered. The composite type of the - selector shall be a nonlimited untagged (but possibly discriminated) - record type, all of whose subcomponent subtypes are either static discrete - subtypes or record types that meet the same restrictions. + selector shall be an array or record type that is neither limited + class-wide. + + If a subcomponent's subtype does not meet certain restrictions, then + the only value that can be specified for that subcomponent in a case + choice expression is a "box" component association (which matches all + possible values for the subcomponent). This restriction applies if + + - the component subtype is not a record, array, or discrete type; or + + - the component subtype is subject to a non-static constraint or + has a predicate; or + + - the component type is an enumeration type that is subject to an + enumeration representation clause; or + + - the component type is a multidimensional array type or an + array type with a nonstatic index subtype. Support for casing on arrays (and on records that contain arrays) is currently subject to some restrictions. Non-positional diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 67fd130..48b7623 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -3582,6 +3582,25 @@ of the pragma in the :title:`GNAT_Reference_manual`). ordering. +.. index:: -gnatw_p (gcc) + +:switch:`-gnatw_p` + *Activate warnings for pedantic checks.* + + This switch activates warnings for the failure of certain pedantic checks. + The only case currently supported is a check that the subtype_marks given + for corresponding formal parameter and function results in a subprogram + declaration and its body denote the same subtype declaration. The default + is that such warnings are not given. + +.. index:: -gnatw_P (gcc) + +:switch:`-gnatw_P` + *Suppress warnings for pedantic checks.* + + This switch suppresses warnings on violations of pedantic checks. + + .. index:: -gnatwq (gcc) .. index:: Parentheses, warnings diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 0274e6b..763b646 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -43,24 +43,87 @@ package body Einfo.Utils is -- Determine whether abstract state State_Id has particular option denoted -- by the name Option_Nam. - ----------------------------------- - -- Renamings of Renamed_Or_Alias -- - ----------------------------------- + ------------------------------------------- + -- Aliases/Renamings of Renamed_Or_Alias -- + ------------------------------------------- function Alias (N : Entity_Id) return Node_Id is begin - pragma Assert - (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type); - return Renamed_Or_Alias (N); + return Val : constant Node_Id := Renamed_Or_Alias (N) do + pragma Assert + (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type); + pragma Assert (Val in N_Entity_Id | N_Empty_Id); + end return; end Alias; procedure Set_Alias (N : Entity_Id; Val : Node_Id) is begin pragma Assert (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type); + pragma Assert (Val in N_Entity_Id | N_Empty_Id); + Set_Renamed_Or_Alias (N, Val); end Set_Alias; + function Renamed_Entity (N : Entity_Id) return Node_Id is + begin + return Val : constant Node_Id := Renamed_Or_Alias (N) do + pragma Assert (not Is_Object (N) or else Etype (N) = Any_Type); + pragma Assert (Val in N_Entity_Id | N_Empty_Id); + end return; + end Renamed_Entity; + + procedure Set_Renamed_Entity (N : Entity_Id; Val : Node_Id) is + begin + pragma Assert (not Is_Object (N)); + pragma Assert (Val in N_Entity_Id); + + Set_Renamed_Or_Alias (N, Val); + end Set_Renamed_Entity; + + function Renamed_Object (N : Entity_Id) return Node_Id is + begin + return Val : constant Node_Id := Renamed_Or_Alias (N) do + -- Formal_Kind uses the entity, not a name of it. This happens + -- in front-end inlining, which also sets to Empty. Also in + -- Exp_Ch9, where formals are renamed for the benefit of gdb. + + if Ekind (N) not in Formal_Kind then + pragma Assert (Is_Object (N)); + pragma Assert (Val in N_Subexpr_Id | N_Empty_Id); + null; + end if; + end return; + end Renamed_Object; + + procedure Set_Renamed_Object (N : Entity_Id; Val : Node_Id) is + begin + if Ekind (N) not in Formal_Kind then + pragma Assert (Is_Object (N)); + pragma Assert (Val in N_Subexpr_Id | N_Empty_Id); + null; + end if; + + Set_Renamed_Or_Alias (N, Val); + end Set_Renamed_Object; + + function Renamed_Entity_Or_Object (N : Entity_Id) return Node_Id is + begin + if Is_Object (N) then + return Renamed_Object (N); + else + return Renamed_Entity (N); + end if; + end Renamed_Entity_Or_Object; + + procedure Set_Renamed_Object_Of_Possibly_Void + (N : Entity_Id; Val : Node_Id) + is + begin + pragma Assert (Val in N_Subexpr_Id); + Set_Renamed_Or_Alias (N, Val); + end Set_Renamed_Object_Of_Possibly_Void; + ---------------- -- Has_Option -- ---------------- @@ -390,34 +453,23 @@ package body Einfo.Utils is function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is begin - return Present (Component_Bit_Offset (E)) + return Known_Component_Bit_Offset (E) and then Component_Bit_Offset (E) >= Uint_0; end Known_Static_Component_Bit_Offset; function Known_Component_Size (E : Entity_Id) return B is begin - return Component_Size (E) /= Uint_0 - and then Present (Component_Size (E)); + return Present (Component_Size (E)); end Known_Component_Size; function Known_Static_Component_Size (E : Entity_Id) return B is begin - return Component_Size (E) > Uint_0; + return Known_Component_Size (E) and then Component_Size (E) >= Uint_0; end Known_Static_Component_Size; - Use_New_Unknown_Rep : constant Boolean := False; - -- If False, we represent "unknown" as Uint_0, which is wrong. - -- We intend to make it True (and remove it), and represent - -- "unknown" as Field_Is_Initial_Zero. We also need to change - -- the type of Esize and RM_Size from Uint to Valid_Uint. - function Known_Esize (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return not Field_Is_Initial_Zero (E, F_Esize); - else - return Present (Esize (E)) and then Esize (E) /= Uint_0; - end if; + return Present (Esize (E)); end Known_Esize; function Known_Static_Esize (E : Entity_Id) return B is @@ -429,11 +481,7 @@ package body Einfo.Utils is procedure Reinit_Esize (Id : E) is begin - if Use_New_Unknown_Rep then - Reinit_Field_To_Zero (Id, F_Esize); - else - Set_Esize (Id, Uint_0); - end if; + Reinit_Field_To_Zero (Id, F_Esize); end Reinit_Esize; procedure Copy_Esize (To, From : E) is @@ -452,7 +500,7 @@ package body Einfo.Utils is function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is begin - return Present (Normalized_First_Bit (E)) + return Known_Normalized_First_Bit (E) and then Normalized_First_Bit (E) >= Uint_0; end Known_Static_Normalized_First_Bit; @@ -463,43 +511,25 @@ package body Einfo.Utils is function Known_Static_Normalized_Position (E : Entity_Id) return B is begin - return Present (Normalized_Position (E)) + return Known_Normalized_Position (E) and then Normalized_Position (E) >= Uint_0; end Known_Static_Normalized_Position; function Known_RM_Size (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return not Field_Is_Initial_Zero (E, F_RM_Size); - else - return Present (RM_Size (E)) - and then (RM_Size (E) /= Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)); - end if; + return Present (RM_Size (E)); end Known_RM_Size; function Known_Static_RM_Size (E : Entity_Id) return B is begin - if Use_New_Unknown_Rep then - return Known_RM_Size (E) - and then RM_Size (E) >= Uint_0 - and then not Is_Generic_Type (E); - else - return (RM_Size (E) > Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)) - and then not Is_Generic_Type (E); - end if; + return Known_RM_Size (E) + and then RM_Size (E) >= Uint_0 + and then not Is_Generic_Type (E); end Known_Static_RM_Size; procedure Reinit_RM_Size (Id : E) is begin - if Use_New_Unknown_Rep then - Reinit_Field_To_Zero (Id, F_RM_Size); - else - Set_RM_Size (Id, Uint_0); - end if; + Reinit_Field_To_Zero (Id, F_RM_Size); end Reinit_RM_Size; procedure Copy_RM_Size (To, From : E) is @@ -541,9 +571,8 @@ package body Einfo.Utils is begin pragma Assert (Is_Type (Id)); pragma Assert (not Known_Esize (Id) or else Esize (Id) = V); - if Use_New_Unknown_Rep then - pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V); - end if; + pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V); + Set_Esize (Id, UI_From_Int (V)); Set_RM_Size (Id, UI_From_Int (V)); end Init_Size; @@ -669,6 +698,30 @@ package body Einfo.Utils is P := Empty; end if; + -- Declarations are sometimes removed by replacing them with other + -- irrelevant nodes. For example, a declare expression can be turned + -- into a literal by constant folding. In these cases we want to + -- return Empty. + + if Nkind (P) in + N_Assignment_Statement + | N_Integer_Literal + | N_Procedure_Call_Statement + | N_Subtype_Indication + | N_Type_Conversion + then + P := Empty; + end if; + + -- The following Assert indicates what kinds of nodes can be returned; + -- they are not all "declarations". + + if Serious_Errors_Detected = 0 then + pragma Assert + (Nkind (P) in N_Is_Decl | N_Empty, + "Declaration_Node incorrect kind: " & Node_Kind'Image (Nkind (P))); + end if; + return P; end Declaration_Node; @@ -2593,6 +2646,16 @@ package body Einfo.Utils is return Scope_Depth_Value (Scop); end Scope_Depth; + function Scope_Depth_Default_0 (Id : E) return U is + begin + if Scope_Depth_Set (Id) then + return Scope_Depth (Id); + + else + return Uint_0; + end if; + end Scope_Depth_Default_0; + --------------------- -- Scope_Depth_Set -- --------------------- diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index 8046722..c82b469 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -27,25 +27,37 @@ with Einfo.Entities; use Einfo.Entities; package Einfo.Utils is - ----------------------------------- - -- Renamings of Renamed_Or_Alias -- - ----------------------------------- + ------------------------------------------- + -- Aliases/Renamings of Renamed_Or_Alias -- + ------------------------------------------- -- See the comment in einfo.ads, "Renaming and Aliasing", which is somewhat - -- incorrect. In fact, the compiler uses Alias, Renamed_Entity, and - -- Renamed_Object more-or-less interchangeably, so we rename them here. - -- Alias isn't really renamed, because we want an assertion in the body. + -- incorrect. Each of the following calls [Set_]Renamed_Or_Alias. Alias and + -- Renamed_Entity are fields of nonobject Entity_Ids, and the value of the + -- field is Entity_Id. Alias is only for callable entities and subprogram + -- types. We sometimes call Set_Renamed_Entity and then expect Alias to + -- return the value set. Renamed_Object is a field of Entity_Ids that are + -- objects, and it returns an expression, because you can rename things + -- like "X.all(J).Y". Renamings of entries and subprograms can also be + -- expressions, but those use different mechanisms; the fields here are not + -- used. function Alias (N : Entity_Id) return Node_Id; procedure Set_Alias (N : Entity_Id; Val : Node_Id); - function Renamed_Entity - (N : Entity_Id) return Node_Id renames Renamed_Or_Alias; - procedure Set_Renamed_Entity - (N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias; - function Renamed_Object - (N : Entity_Id) return Node_Id renames Renamed_Or_Alias; - procedure Set_Renamed_Object - (N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias; + function Renamed_Entity (N : Entity_Id) return Node_Id; + procedure Set_Renamed_Entity (N : Entity_Id; Val : Node_Id); + function Renamed_Object (N : Entity_Id) return Node_Id; + procedure Set_Renamed_Object (N : Entity_Id; Val : Node_Id); + + function Renamed_Entity_Or_Object (N : Entity_Id) return Node_Id; + -- This getter is used when we don't know statically whether we want to + -- call Renamed_Entity or Renamed_Object. + + procedure Set_Renamed_Object_Of_Possibly_Void + (N : Entity_Id; Val : Node_Id); + -- Set_Renamed_Object doesn't allow Void; this is used in the rare cases + -- where we set the field of an entity that might be Void. It might be a + -- good idea to get rid of calls to this. pragma Inline (Alias); pragma Inline (Set_Alias); @@ -53,6 +65,8 @@ package Einfo.Utils is pragma Inline (Set_Renamed_Entity); pragma Inline (Renamed_Object); pragma Inline (Set_Renamed_Object); + pragma Inline (Renamed_Entity_Or_Object); + pragma Inline (Set_Renamed_Object_Of_Possibly_Void); ------------------- -- Type Synonyms -- @@ -274,14 +288,21 @@ package Einfo.Utils is function Safe_Emax_Value (Id : E) return U; function Safe_First_Value (Id : E) return R; function Safe_Last_Value (Id : E) return R; - function Scope_Depth (Id : E) return U; - function Scope_Depth_Set (Id : E) return B; function Size_Clause (Id : E) return N; function Stream_Size_Clause (Id : E) return N; function Type_High_Bound (Id : E) return N; function Type_Low_Bound (Id : E) return N; function Underlying_Type (Id : E) return E; + function Scope_Depth (Id : E) return U; + function Scope_Depth_Set (Id : E) return B; + + function Scope_Depth_Default_0 (Id : E) return U; + -- In rare cases, the Scope_Depth_Value (queried by Scope_Depth) is + -- not correctly set before querying it; this may be used instead of + -- Scope_Depth in such cases. It returns Uint_0 if the Scope_Depth_Value + -- has not been set. See documentation in Einfo. + pragma Inline (Address_Clause); pragma Inline (Alignment_Clause); pragma Inline (Base_Type); @@ -314,41 +335,58 @@ package Einfo.Utils is -- Type Representation Attribute Fields -- ------------------------------------------ - -- Each of the following fields can be in a "known" or "unknown" state: + function Known_Alignment (E : Entity_Id) return B with Inline; + procedure Reinit_Alignment (Id : E) with Inline; + procedure Copy_Alignment (To, From : E); + + function Known_Component_Bit_Offset (E : Entity_Id) return B with Inline; + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B + with Inline; + + function Known_Component_Size (E : Entity_Id) return B with Inline; + function Known_Static_Component_Size (E : Entity_Id) return B with Inline; + + function Known_Esize (E : Entity_Id) return B with Inline; + function Known_Static_Esize (E : Entity_Id) return B with Inline; + procedure Reinit_Esize (Id : E) with Inline; + procedure Copy_Esize (To, From : E); + + function Known_Normalized_First_Bit (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B + with Inline; + + function Known_Normalized_Position (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_Position (E : Entity_Id) return B + with Inline; + + function Known_RM_Size (E : Entity_Id) return B with Inline; + function Known_Static_RM_Size (E : Entity_Id) return B with Inline; + procedure Reinit_RM_Size (Id : E) with Inline; + procedure Copy_RM_Size (To, From : E); - -- Alignment - -- Component_Size - -- Component_Bit_Offset - -- Digits_Value - -- Esize - -- Normalized_First_Bit - -- Normalized_Position - -- RM_Size - -- -- NOTE: "known" here does not mean "known at compile time". It means that -- the compiler has computed the value of the field (either by default, or -- by noting some representation clauses), and the field has not been -- reinitialized. -- - -- We document the Esize functions here; the others are analogous: + -- We document the Esize functions here; the others above are analogous: -- -- Known_Esize: True if Set_Esize has been called without a subsequent -- Reinit_Esize. -- -- Known_Static_Esize: True if Known_Esize and the Esize is known at -- compile time. (We're not using "static" in the Ada RM sense here. We - -- are using it to mean "known at compile time.) + -- are using it to mean "known at compile time".) -- -- Reinit_Esize: Set the Esize field to its initial unknown state. -- -- Copy_Esize: Copies the Esize from From to To; Known_Esize (From) may -- be False, in which case Known_Esize (To) becomes False. -- - -- Esize: This is the normal automatially-generated getter for Esize, - -- declared elsewhere. It is an error to call this if Set_Esize has not - -- yet been called, or if Reinit_Esize has been called subsequently. + -- Esize: This is the normal automatically-generated getter for Esize, + -- declared elsewhere. Returns No_Uint if not Known_Esize. -- - -- Set_Esize: This is the normal automatially-generated setter for + -- Set_Esize: This is the normal automatically-generated setter for -- Esize. After a call to this, Known_Esize is True. It is an error -- to call this with a No_Uint value. -- @@ -357,13 +395,6 @@ package Einfo.Utils is -- before calling Esize, because the code is written in such a way that we -- don't know whether Set_Esize has already been called. -- - -- We intend to use the initial zero value to represent "unknown". Note - -- that this value is different from No_Uint, and different from Uint_0. - -- However, this is work in progress; we are still using No_Uint or Uint_0 - -- to represent "unknown" in some cases. Using Uint_0 leads to several - -- bugs, because zero is a legitimate value (T'Size can be zero bits) -- - -- Uint_0 shouldn't mean two different things. - -- -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one -- more consideration, which is that we always return False for generic -- types. Within a template, the size can look Known_Static, because of the @@ -371,35 +402,6 @@ package Einfo.Utils is -- Known_Static and anyone testing if they are Known_Static within the -- template should get False as a result to prevent incorrect assumptions. - function Known_Alignment (E : Entity_Id) return B with Inline; - procedure Reinit_Alignment (Id : E) with Inline; - procedure Copy_Alignment (To, From : E); - - function Known_Component_Bit_Offset (E : Entity_Id) return B with Inline; - function Known_Static_Component_Bit_Offset (E : Entity_Id) return B - with Inline; - - function Known_Component_Size (E : Entity_Id) return B with Inline; - function Known_Static_Component_Size (E : Entity_Id) return B with Inline; - - function Known_Esize (E : Entity_Id) return B with Inline; - function Known_Static_Esize (E : Entity_Id) return B with Inline; - procedure Reinit_Esize (Id : E) with Inline; - procedure Copy_Esize (To, From : E); - - function Known_Normalized_First_Bit (E : Entity_Id) return B with Inline; - function Known_Static_Normalized_First_Bit (E : Entity_Id) return B - with Inline; - - function Known_Normalized_Position (E : Entity_Id) return B with Inline; - function Known_Static_Normalized_Position (E : Entity_Id) return B - with Inline; - - function Known_RM_Size (E : Entity_Id) return B with Inline; - function Known_Static_RM_Size (E : Entity_Id) return B with Inline; - procedure Reinit_RM_Size (Id : E) with Inline; - procedure Copy_RM_Size (To, From : E); - --------------------------------------------------------- -- Procedures for setting multiple of the above fields -- --------------------------------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0239a70..51cb014 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4323,7 +4323,8 @@ package Einfo is -- Indicates the number of scopes that statically enclose the declaration -- of the unit or type. Library units have a depth of zero. Note that -- record types can act as scopes but do NOT have this field set (see --- Scope_Depth above). +-- Scope_Depth above). Queries should normally be via Scope_Depth, +-- and not call Scope_Depth_Value directly. -- Scope_Depth_Set (synthesized) -- Applies to a special predicate function that returns a Boolean value @@ -4555,7 +4556,7 @@ package Einfo is -- in inheritance of subprograms between views of the same type. -- Subps_Index --- Present in subprogram entries. Set if the subprogram contains nested +-- Present in subprogram entities. Set if the subprogram contains nested -- subprograms, or is a subprogram nested within such a subprogram. Holds -- the index in the Exp_Unst.Subps table for the subprogram. Note that -- for the outer level subprogram, this is the starting index in the Subp @@ -4761,7 +4762,7 @@ package Einfo is -- Several entity attributes relate to renaming constructs, and to the use of -- different names to refer to the same entity. The following is a summary of --- these constructs and their prefered uses. +-- these constructs and their preferred uses. -- There are three related attributes: @@ -4774,7 +4775,7 @@ package Einfo is -- a) Renamed_Entity applies to entities in renaming declarations that rename -- an entity, so the value of the attribute IS an entity. This applies to --- generic renamings, package renamings, exception renamings, and subprograms +-- generic renamings, package renamings, exception renamings, and subprogram -- renamings that rename a subprogram (rather than an attribute, an entry, a -- protected operation, etc). @@ -4796,9 +4797,9 @@ package Einfo is -- in a few cases we need to use a loop to trace a chain of object renamings -- where all of them happen to be entities. So: --- X : integer; --- Y : integer renames X; -- renamed object is the identifier X --- Z : integer renames Y; -- renamed object is the identifier Y +-- X : Integer; +-- Y : Integer renames X; -- renamed object is the identifier X +-- Z : Integer renames Y; -- renamed object is the identifier Y -- The front-end does not store explicitly the fact that Z renames X. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 05a8266..76a8268 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -211,12 +211,9 @@ package body Errout is -- This is called for warning messages only (so Warning_Msg_Char is set) -- and returns a corresponding string to use at the beginning of generated -- auxiliary messages, such as "in instantiation at ...". - -- 'a' .. 'z' returns "?x?" - -- 'A' .. 'Z' returns "?X?" - -- '*' returns "?*?" - -- '$' returns "?$?info: " - -- ' ' returns " " - -- No other settings are valid + -- "?" returns "??" + -- " " returns "?" + -- other trimmed, prefixed and suffixed with "?". ----------------------- -- Change_Error_Text -- @@ -1177,7 +1174,7 @@ package body Errout is Errors.Table (Cur_Msg).Warn := True; Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; - elsif Warning_Msg_Char /= ' ' then + elsif Warning_Msg_Char /= " " then Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; end if; end if; @@ -3927,12 +3924,15 @@ package body Errout is P : Natural; -- Current index; procedure Skip_Msg_Insertion_Warning (C : Character); - -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same + -- Skip the ? ?? ?x? ?*? ?$? insertion sequences (and the same -- sequences using < instead of ?). The caller has already bumped -- the pointer past the initial ? or < and C is set to this initial -- character (? or <). This procedure skips past the rest of the -- sequence. We do not need to set Msg_Insertion_Char, since this -- was already done during the message prescan. + -- No validity check is performed as the insertion sequence is + -- supposed to be sane. See Prescan_Message.Parse_Message_Class in + -- erroutc.adb for the validity checks. -------------------------------- -- Skip_Msg_Insertion_Warning -- @@ -3943,17 +3943,16 @@ package body Errout is if P <= Text'Last and then Text (P) = C then P := P + 1; - elsif P + 1 <= Text'Last - and then (Text (P) in 'a' .. 'z' - or else - Text (P) in 'A' .. 'Z' - or else - Text (P) = '*' - or else - Text (P) = '$') - and then Text (P + 1) = C + elsif P < Text'Last and then Text (P + 1) = C + and then Text (P) in 'a' .. 'z' | '*' | '$' then P := P + 2; + + elsif P + 1 < Text'Last and then Text (P + 2) = C + and then Text (P) in '.' | '_' + and then Text (P + 1) in 'a' .. 'z' + then + P := P + 3; end if; end Skip_Msg_Insertion_Warning; @@ -4404,19 +4403,15 @@ package body Errout is function Warn_Insertion return String is begin - case Warning_Msg_Char is - when '?' => - return "??"; - - when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' => - return '?' & Warning_Msg_Char & '?'; - - when ' ' => - return "?"; - - when others => - raise Program_Error; - end case; + if Warning_Msg_Char = "? " then + return "??"; + elsif Warning_Msg_Char = " " then + return "?"; + elsif Warning_Msg_Char (2) = ' ' then + return '?' & Warning_Msg_Char (1) & '?'; + else + return '?' & Warning_Msg_Char & '?'; + end if; end Warn_Insertion; end Errout; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 9b2e08d..60b1b4f 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -60,13 +60,13 @@ package Errout is -- Exception raised if Raise_Exception_On_Error is true Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch; - -- If this is set True, then the ??/?*?/?$?/?x?/?X? insertion sequences in - -- error messages generate appropriate tags for the output error messages. - -- If this switch is False, then these sequences are still recognized (for - -- the purposes of implementing the pattern matching in pragmas Warnings - -- (Off,..) and Warning_As_Pragma(...) but do not result in adding the - -- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D - -- sets this flag False. + -- If this is set True, then the ??/?*?/?$?/?x?/?.x?/?_x? insertion + -- sequences in error messages generate appropriate tags for the output + -- error messages. If this switch is False, then these sequences are still + -- recognized (for the purposes of implementing the pattern matching in + -- pragmas Warnings (Off,..) and Warning_As_Pragma(...) but do not result + -- in adding the error message tag. The -gnatw.d switch sets this flag + -- True, -gnatw.D sets this flag False. Current_Node : Node_Id := Empty; -- Used by Error_Msg as a default Node_Id. @@ -302,28 +302,23 @@ package Errout is -- clear that the continuation is part of a warning message, but it is -- not necessary to go through any computational effort to include it. -- - -- Note: this usage is obsolete, use ?? ?*? ?$? ?x? ?X? to specify - -- the string to be added when Warn_Doc_Switch is set to True. If this - -- switch is True, then for simple ? messages it has no effect. This - -- simple form is to ease transition and may be removed later except - -- for GNATprove-specific messages (info and warnings) which are not - -- subject to the same GNAT warning switches. + -- Note: this usage is obsolete, use ?? ?*? ?$? ?x? ?.x? ?_x? to + -- specify the string to be added when Warn_Doc_Switch is set to True. + -- If this switch is True, then for simple ? messages it has no effect. + -- This simple form is to ease transition and may be removed later + -- except for GNATprove-specific messages (info and warnings) which are + -- not subject to the same GNAT warning switches. -- Insertion character ?? (Two question marks: default warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string -- "[enabled by default]" at the end of the warning message. For -- continuations, use this in each continuation message. - -- Insertion character ?x? (warning with switch) + -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string - -- "[-gnatwx]" at the end of the warning message. x is a lower case - -- letter. For continuations, use this on each continuation message. - - -- Insertion character ?X? (warning with dot switch) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string - -- "[-gnatw.x]" at the end of the warning message. X is an upper case - -- letter corresponding to the lower case letter x in the message. - -- For continuations, use this on each continuation message. + -- "[-gnatwx]", "[-gnatw.x]", or "[-gnatw_x]", at the end of the + -- warning message. x must be lower case. For continuations, use this + -- on each continuation message. -- Insertion character ?*? (restriction warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string @@ -339,8 +334,8 @@ package Errout is -- Insertion character < (Less Than: conditional warning message) -- The character < appearing anywhere in a message is used for a -- conditional error message. If Error_Msg_Warn is True, then the - -- effect is the same as ? described above, and in particular << <X< - -- <x< <$< <*< have the effect of ?? ?X? ?x? ?$? ?*? respectively. If + -- effect is the same as ? described above, and in particular << <x< + -- <$< <*< have the effect of ?? ?x? ?$? ?*? respectively. If -- Error_Msg_Warn is False, then the < << or <X< sequence is ignored -- and the message is treated as a error rather than a warning. diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 9e67b92..8225fd4 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -277,7 +277,9 @@ package body Erroutc is begin for J in 1 .. Errors.Last loop begin - if Errors.Table (J).Warn and Errors.Table (J).Compile_Time_Pragma + if Errors.Table (J).Warn + and then Errors.Table (J).Compile_Time_Pragma + and then not Errors.Table (J).Deleted then Result := Result + 1; end if; @@ -362,20 +364,20 @@ package body Erroutc is --------------------- function Get_Warning_Tag (Id : Error_Msg_Id) return String is - Warn : constant Boolean := Errors.Table (Id).Warn; - Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr; + Warn : constant Boolean := Errors.Table (Id).Warn; + Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; begin - if Warn and then Warn_Chr /= ' ' then - if Warn_Chr = '?' then + if Warn and then Warn_Chr /= " " then + if Warn_Chr = "? " then return "[enabled by default]"; - elsif Warn_Chr = '*' then + elsif Warn_Chr = "* " then return "[restriction warning]"; - elsif Warn_Chr = '$' then + elsif Warn_Chr = "$ " then return "[-gnatel]"; - elsif Warn_Chr in 'a' .. 'z' then + elsif Warn_Chr (2) = ' ' then + return "[-gnatw" & Warn_Chr (1) & ']'; + else return "[-gnatw" & Warn_Chr & ']'; - else pragma Assert (Warn_Chr in 'A' .. 'Z'); - return "[-gnatw." & Fold_Lower (Warn_Chr) & ']'; end if; else return ""; @@ -839,6 +841,51 @@ package body Erroutc is procedure Prescan_Message (Msg : String) is J : Natural; + function Parse_Message_Class return String; + -- Convert the warning insertion sequence to a warning class represented + -- as a length-two string padded, if necessary, with spaces. + -- Return the Message class and set the iterator J to the character + -- following the sequence. + -- Raise a Program_Error if the insertion sequence is not valid. + + ------------------------- + -- Parse_Message_Class -- + ------------------------- + + function Parse_Message_Class return String is + C : constant Character := Msg (J - 1); + Message_Class : String (1 .. 2) := " "; + begin + if J <= Msg'Last and then Msg (J) = C then + Message_Class := "? "; + J := J + 1; + + elsif J < Msg'Last and then Msg (J + 1) = C + and then Msg (J) in 'a' .. 'z' | '*' | '$' + then + Message_Class := Msg (J) & " "; + J := J + 2; + + elsif J + 1 < Msg'Last and then Msg (J + 2) = C + and then Msg (J) in '.' | '_' + and then Msg (J + 1) in 'a' .. 'z' + then + Message_Class := Msg (J .. J + 1); + J := J + 3; + elsif (J < Msg'Last and then Msg (J + 1) = C) or else + (J + 1 < Msg'Last and then Msg (J + 2) = C) + then + raise Program_Error; + end if; + + -- In any other cases, this is not a warning insertion sequence + -- and the default " " value is returned. + + return Message_Class; + end Parse_Message_Class; + + -- Start of processing for Prescan_Message + begin -- Nothing to do for continuation line, unless -gnatdF is set @@ -846,7 +893,7 @@ package body Erroutc is return; -- Some global variables are not set for continuation messages, as they - -- only make sense for the initial mesage. + -- only make sense for the initial message. elsif Msg (Msg'First) /= '\' then @@ -898,29 +945,10 @@ package body Erroutc is elsif Msg (J) = '?' or else Msg (J) = '<' then Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn; - Warning_Msg_Char := ' '; J := J + 1; if Is_Warning_Msg then - declare - C : constant Character := Msg (J - 1); - begin - if J <= Msg'Last then - if Msg (J) = C then - Warning_Msg_Char := '?'; - J := J + 1; - - elsif J < Msg'Last and then Msg (J + 1) = C - and then (Msg (J) in 'a' .. 'z' or else - Msg (J) in 'A' .. 'Z' or else - Msg (J) = '*' or else - Msg (J) = '$') - then - Warning_Msg_Char := Msg (J); - J := J + 2; - end if; - end if; - end; + Warning_Msg_Char := Parse_Message_Class; end if; -- Bomb if untagged warning message. This code can be uncommented @@ -1685,7 +1713,7 @@ package body Erroutc is if SWE.Open then Eproc.all - ("?W?pragma Warnings Off with no matching Warnings On", + ("?.w?pragma Warnings Off with no matching Warnings On", SWE.Start); -- Warn for ineffective Warnings (Off, ..) @@ -1700,7 +1728,7 @@ package body Erroutc is (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W") then Eproc.all - ("?W?no warning suppressed by this pragma", SWE.Start); + ("?.w?no warning suppressed by this pragma", SWE.Start); end if; end if; end; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 891391c..0c194e8 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -80,14 +80,14 @@ package Erroutc is -- 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 - -- '?' -- ?? or << appeared in message - -- 'x' -- ?x? or <x< appeared in message (x = a .. z) - -- 'X' -- ?X? or <X< appeared in message (X = A .. Z) - -- '*' -- ?*? or <*< appeared in message - -- '$' -- ?$? or <$< appeared in message + Warning_Msg_Char : String (1 .. 2); + -- Warning switch, valid only if Is_Warning_Msg is True + -- " " -- ? or < appeared on its own in message + -- "? " -- ?? or << appeared in message + -- "x " -- ?x? or <x< appeared in message + -- -- (x = a .. z | A .. Z | * | $) + -- ".x" -- ?.x? appeared in message (x = a .. z | A .. Z) + -- "_x" -- ?_x? appeared in message (x = a .. z | A .. Z) -- In the case of the < sequences, this is set only if the message is -- actually a warning, i.e. if Error_Msg_Warn is True @@ -239,16 +239,8 @@ package Erroutc is -- 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. - Warn_Chr : Character; - -- Warning character (note: set even if Warning_Doc_Switch is False) - -- ' ' -- ? or < appeared on its own in message - -- '?' -- ?? or << appeared in message - -- 'x' -- ?x? or <x< appeared in message (x = a .. z) - -- 'X' -- ?X? or <X< appeared in message (X = A .. Z) - -- '*' -- ?*? or <*< appeared in message - -- '$' -- ?$? or <$< appeared in message - -- In the case of the < sequences, this is set only if the message is - -- actually a warning, i.e. if Error_Msg_Warn is True + Warn_Chr : String (1 .. 2); + -- See Warning_Msg_Char Style : Boolean; -- True if style message (starts with "(style)") diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 71bad3c..f3d83a5 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -490,7 +490,7 @@ package body Exp_Aggr is -- Fat pointers are rejected as they are not really elementary -- for the backend. - if Csiz /= System_Address_Size then + if No (Csiz) or else Csiz /= System_Address_Size then return False; end if; @@ -504,8 +504,7 @@ package body Exp_Aggr is -- Scalar types are OK if their size is a multiple of Storage_Unit - elsif Is_Scalar_Type (Ctyp) then - pragma Assert (Present (Csiz)); + elsif Is_Scalar_Type (Ctyp) and then Present (Csiz) then if Csiz mod System_Storage_Unit /= 0 then return False; @@ -3209,6 +3208,8 @@ package body Exp_Aggr is Init_Stmt : Node_Id; begin + pragma Assert (Nkind (Init_Expr) in N_Subexpr); + -- Protect the initialization statements from aborts. Generate: -- Abort_Defer; @@ -3793,6 +3794,26 @@ package body Exp_Aggr is With_Default_Init => True, Constructor_Ref => Expression (Comp))); + elsif Box_Present (Comp) + and then Needs_Simple_Initialization (Etype (Selector)) + then + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Selector, Loc)); + + Initialize_Record_Component + (Rec_Comp => Comp_Expr, + Comp_Typ => Etype (Selector), + Init_Expr => Get_Simple_Init_Val + (Typ => Etype (Selector), + N => Comp, + Size => + (if Known_Esize (Selector) + then Esize (Selector) + else Uint_0)), + Stmts => L); + -- Ada 2005 (AI-287): For each default-initialized component generate -- a call to the corresponding IP subprogram if available. @@ -8547,10 +8568,6 @@ package body Exp_Aggr is Expr_Q : Node_Id; begin - if No (Comps) then - return True; - end if; - C := First (Comps); while Present (C) loop @@ -8901,46 +8918,41 @@ package body Exp_Aggr is ---------------------------- function Has_Default_Init_Comps (N : Node_Id) return Boolean is - Comps : constant List_Id := Component_Associations (N); - C : Node_Id; + Assoc : Node_Id; Expr : Node_Id; + -- Component association and expression, respectively begin pragma Assert (Nkind (N) in N_Aggregate | N_Extension_Aggregate); - if No (Comps) then - return False; - end if; - if Has_Self_Reference (N) then return True; end if; - -- Check if any direct component has default initialized components + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + -- Each component association has either a box or an expression + + pragma Assert (Box_Present (Assoc) xor Present (Expression (Assoc))); - C := First (Comps); - while Present (C) loop - if Box_Present (C) then - return True; - end if; + -- Check if any direct component has default initialized components - Next (C); - end loop; + if Box_Present (Assoc) then + return True; - -- Recursive call in case of aggregate expression + -- Recursive call in case of aggregate expression - C := First (Comps); - while Present (C) loop - Expr := Expression (C); + else + Expr := Expression (Assoc); - if Present (Expr) - and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate - and then Has_Default_Init_Comps (Expr) - then - return True; + if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate + and then Has_Default_Init_Comps (Expr) + then + return True; + end if; end if; - Next (C); + Next (Assoc); end loop; return False; @@ -8987,11 +8999,8 @@ package body Exp_Aggr is Kind := Nkind (Node); end if; - if Kind not in N_Aggregate | N_Extension_Aggregate then - return False; - else - return Expansion_Delayed (Node); - end if; + return Kind in N_Aggregate | N_Extension_Aggregate + and then Expansion_Delayed (Node); end Is_Delayed_Aggregate; -------------------------------- @@ -9088,11 +9097,11 @@ package body Exp_Aggr is ----------------------------- function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is - C : constant Int := UI_To_Int (Component_Size (Typ)); + C : constant Uint := Component_Size (Typ); begin return Number_Dimensions (Typ) = 2 and then Is_Bit_Packed_Array (Typ) - and then (C = 1 or else C = 2 or else C = 4); + and then C in Uint_1 | Uint_2 | Uint_4; -- False if No_Uint end Is_Two_Dim_Packed_Array; -------------------- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 096671f..19d8286 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3898,8 +3898,8 @@ package body Exp_Attr is if Ptyp = Standard_Exception_Type then Id_Kind := RTE (RE_Exception_Id); - if Present (Renamed_Object (Entity (Pref))) then - Set_Entity (Pref, Renamed_Object (Entity (Pref))); + if Present (Renamed_Entity (Entity (Pref))) then + Set_Entity (Pref, Renamed_Entity (Entity (Pref))); end if; Rewrite (N, @@ -6294,7 +6294,7 @@ package body Exp_Attr is -- size. This applies to both types and objects. The size of an -- object can be specified in the following ways: - -- An explicit size object is given for an object + -- An explicit size clause is given for an object -- A component size is specified for an indexed component -- A component clause is specified for a selected component -- The object is a component of a packed composite object @@ -6310,7 +6310,7 @@ package body Exp_Attr is or else Is_Packed (Etype (Prefix (Pref))))) or else (Nkind (Pref) = N_Indexed_Component - and then (Component_Size (Etype (Prefix (Pref))) /= 0 + and then (Known_Component_Size (Etype (Prefix (Pref))) or else Is_Packed (Etype (Prefix (Pref))))) then Set_Attribute_Name (N, Name_Size); @@ -7970,7 +7970,6 @@ package body Exp_Attr is elsif Id = Attribute_Size and then Is_Entity_Name (Pref) and then Is_Object (Entity (Pref)) - and then Known_Esize (Entity (Pref)) and then Known_Static_Esize (Entity (Pref)) then Siz := Esize (Entity (Pref)); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 40288e4..b8a9a8d 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1667,8 +1667,8 @@ package body Exp_Ch11 is -- If the exception is a renaming, use the exception that it -- renames (which might be a predefined exception, e.g.). - if Present (Renamed_Object (Id)) then - Id := Renamed_Object (Id); + if Present (Renamed_Entity (Id)) then + Id := Renamed_Entity (Id); end if; -- Build a C-compatible string in case of no exception handlers, @@ -1861,10 +1861,10 @@ package body Exp_Ch11 is if Configurable_Run_Time_Mode then Error_Msg_NE - ("\?X?& may call Last_Chance_Handler", N, E); + ("\?.x?& may call Last_Chance_Handler", N, E); else Error_Msg_NE - ("\?X?& may result in unhandled exception", N, E); + ("\?.x?& may result in unhandled exception", N, E); end if; end if; end; @@ -2163,7 +2163,7 @@ package body Exp_Ch11 is Warn_No_Exception_Propagation_Active (N); Error_Msg_N - ("\?X?this handler can never be entered, and has been removed", N); + ("\?.x?this handler can never be entered, and has been removed", N); end if; end Warn_If_No_Local_Raise; @@ -2180,10 +2180,10 @@ package body Exp_Ch11 is if Configurable_Run_Time_Mode then Error_Msg_N - ("\?X?Last_Chance_Handler will be called on exception", N); + ("\?.x?Last_Chance_Handler will be called on exception", N); else Error_Msg_N - ("\?X?execution may raise unhandled exception", N); + ("\?.x?execution may raise unhandled exception", N); end if; end if; end Warn_If_No_Propagation; @@ -2195,7 +2195,7 @@ package body Exp_Ch11 is procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is begin Error_Msg_N - ("?X?pragma Restrictions (No_Exception_Propagation) in effect", N); + ("?.x?pragma Restrictions (No_Exception_Propagation) in effect", N); end Warn_No_Exception_Propagation_Active; end Exp_Ch11; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 418306f..00a6b6c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -332,10 +332,9 @@ package body Exp_Ch3 is -- no declarations and no statements. function Predef_Stream_Attr_Spec - (Loc : Source_Ptr; - Tag_Typ : Entity_Id; - Name : TSS_Name_Type; - For_Body : Boolean := False) return Node_Id; + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type) return Node_Id; -- Specialized version of Predef_Spec_Or_Body that apply to read, write, -- input and output attribute whose specs are constructed in Exp_Strm. @@ -943,11 +942,11 @@ package body Exp_Ch3 is (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id; -- Build a case statement containing only two alternatives. The first - -- alternative corresponds exactly to the discrete choices given on the - -- variant with contains the components that we are generating the - -- checks for. If the discriminant is one of these return False. The - -- second alternative is an OTHERS choice that will return True - -- indicating the discriminant did not match. + -- alternative corresponds to the discrete choices given on the variant + -- that contains the components that we are generating the checks + -- for. If the discriminant is one of these return False. The second + -- alternative is an OTHERS choice that returns True indicating the + -- discriminant did not match. function Build_Dcheck_Function (Case_Id : Entity_Id; @@ -977,6 +976,7 @@ package body Exp_Ch3 is begin Case_Node := New_Node (N_Case_Statement, Loc); + Set_End_Span (Case_Node, Uint_0); -- Replace the discriminant which controls the variant with the name -- of the formal of the checking function. @@ -3206,9 +3206,7 @@ package body Exp_Ch3 is -- types moving any expanded code from the spec to the body of the -- init procedure. - if Is_Task_Record_Type (Rec_Type) - or else Is_Protected_Record_Type (Rec_Type) - then + if Is_Concurrent_Record_Type (Rec_Type) then declare Decl : constant Node_Id := Parent (Corresponding_Concurrent_Type (Rec_Type)); @@ -3589,12 +3587,11 @@ package body Exp_Ch3 is end loop; end if; end; - end if; -- For a protected type, add statements generated by -- Make_Initialize_Protection. - if Is_Protected_Record_Type (Rec_Type) then + elsif Is_Protected_Record_Type (Rec_Type) then Append_List_To (Stmts, Make_Initialize_Protection (Rec_Type)); end if; @@ -10615,11 +10612,9 @@ package body Exp_Ch3 is -- Disp_Requeue -- Disp_Timed_Select - -- Disable the generation of these bodies if No_Dispatching_Calls, - -- Ravenscar or ZFP is active. + -- Disable the generation of these bodies if Ravenscar or ZFP is active if Ada_Version >= Ada_2005 - and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Select_Statements) and then RTE_Available (RE_Select_Specific_Data) then @@ -10910,10 +10905,9 @@ package body Exp_Ch3 is ----------------------------- function Predef_Stream_Attr_Spec - (Loc : Source_Ptr; - Tag_Typ : Entity_Id; - Name : TSS_Name_Type; - For_Body : Boolean := False) return Node_Id + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type) return Node_Id is Ret_Type : Entity_Id; @@ -10931,7 +10925,7 @@ package body Exp_Ch3 is Tag_Typ => Tag_Typ, Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), Ret_Type => Ret_Type, - For_Body => For_Body); + For_Body => False); end Predef_Stream_Attr_Spec; --------------------------------- @@ -10978,16 +10972,13 @@ package body Exp_Ch3 is while Present (Prim) loop if Chars (Node (Prim)) = Name_Op_Eq and then not Is_Internal (Node (Prim)) - and then Present (First_Entity (Node (Prim))) -- The predefined equality primitive must have exactly two - -- formals whose type is this tagged type + -- formals whose type is this tagged type. - and then Present (Last_Entity (Node (Prim))) - and then Next_Entity (First_Entity (Node (Prim))) - = Last_Entity (Node (Prim)) - and then Etype (First_Entity (Node (Prim))) = Tag_Typ - and then Etype (Last_Entity (Node (Prim))) = Tag_Typ + and then Number_Formals (Node (Prim)) = 2 + and then Etype (First_Formal (Node (Prim))) = Tag_Typ + and then Etype (Last_Formal (Node (Prim))) = Tag_Typ then Eq_Needed := False; Eq_Name := No_Name; @@ -11099,8 +11090,7 @@ package body Exp_Ch3 is -- The interface versions will have null bodies - -- Disable the generation of these bodies if No_Dispatching_Calls, - -- Ravenscar or ZFP is active. + -- Disable the generation of these bodies if Ravenscar or ZFP is active -- In VM targets we define these primitives in all root tagged types -- that are not interface types. Done because in VM targets we don't @@ -11109,7 +11099,6 @@ package body Exp_Ch3 is -- they may be ancestors of synchronized interface types). if Ada_Version >= Ada_2005 - and then not Is_Interface (Tag_Typ) and then ((Is_Interface (Etype (Tag_Typ)) and then Is_Limited_Record (Etype (Tag_Typ))) @@ -11119,7 +11108,6 @@ package body Exp_Ch3 is or else (not Tagged_Type_Expansion and then Tag_Typ = Root_Type (Tag_Typ))) - and then not Restriction_Active (No_Dispatching_Calls) and then not Restriction_Active (No_Select_Statements) and then RTE_Available (RE_Select_Specific_Data) then @@ -11131,7 +11119,7 @@ package body Exp_Ch3 is Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); end if; - if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then + if not Is_Limited_Type (Tag_Typ) then -- Body for equality diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8dcfa85..1eebde4 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2583,7 +2583,7 @@ package body Exp_Ch4 is return Make_Function_Call (Loc, - Name => New_Occurrence_Of (Eq_Op, Loc), + Name => New_Occurrence_Of (Eq_Op, Loc), Parameter_Associations => New_List (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs), @@ -2606,7 +2606,7 @@ package body Exp_Ch4 is begin return Make_Function_Call (Loc, - Name => New_Occurrence_Of (Eq_Op, Loc), + Name => New_Occurrence_Of (Eq_Op, Loc), Parameter_Associations => New_List ( OK_Convert_To (T, Lhs), OK_Convert_To (T, Rhs))); @@ -4592,7 +4592,7 @@ package body Exp_Ch4 is and then Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration) then - Error_Msg_N ("??use of an anonymous access type allocator", N); + Error_Msg_N ("?_a?use of an anonymous access type allocator", N); end if; -- RM E.2.2(17). We enforce that the expected type of an allocator @@ -13116,41 +13116,35 @@ package body Exp_Ch4 is ------------------------ function Element_To_Compare (C : Entity_Id) return Entity_Id is - Comp : Entity_Id; + Comp : Entity_Id := C; begin - Comp := C; - loop - -- Exit loop when the next element to be compared is found, or - -- there is no more such element. - - exit when No (Comp); - - exit when Ekind (Comp) in E_Discriminant | E_Component - and then not ( + while Present (Comp) loop + -- Skip inherited components - -- Skip inherited components + -- Note: for a tagged type, we always generate the "=" primitive + -- for the base type (not on the first subtype), so the test for + -- Comp /= Original_Record_Component (Comp) is True for inherited + -- components only. - -- Note: for a tagged type, we always generate the "=" primitive - -- for the base type (not on the first subtype), so the test for - -- Comp /= Original_Record_Component (Comp) is True for - -- inherited components only. - - (Is_Tagged_Type (Typ) + if (Is_Tagged_Type (Typ) and then Comp /= Original_Record_Component (Comp)) - -- Skip _Tag + -- Skip _Tag or else Chars (Comp) = Name_uTag - -- Skip interface elements (secondary tags???) - - or else Is_Interface (Etype (Comp))); + -- Skip interface elements (secondary tags???) - Next_Entity (Comp); + or else Is_Interface (Etype (Comp)) + then + Next_Component_Or_Discriminant (Comp); + else + return Comp; + end if; end loop; - return Comp; + return Empty; end Element_To_Compare; -- Start of processing for Expand_Record_Equality @@ -13166,7 +13160,7 @@ package body Exp_Ch4 is -- and then Lhs.Cmpn = Rhs.Cmpn Result := New_Occurrence_Of (Standard_True, Loc); - C := Element_To_Compare (First_Entity (Typ)); + C := Element_To_Compare (First_Component_Or_Discriminant (Typ)); while Present (C) loop declare New_Lhs : Node_Id; @@ -13224,7 +13218,7 @@ package body Exp_Ch4 is end; First_Time := False; - C := Element_To_Compare (Next_Entity (C)); + C := Element_To_Compare (Next_Component_Or_Discriminant (C)); end loop; return Result; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 21ac2a2..47c6b80 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2387,6 +2387,7 @@ package body Exp_Ch5 is Ent := Name (N); while Nkind (Ent) in N_Has_Entity and then Present (Entity (Ent)) + and then Is_Object (Entity (Ent)) and then Present (Renamed_Object (Entity (Ent))) loop Ent := Renamed_Object (Entity (Ent)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ce0bb80..6015993 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3143,6 +3143,13 @@ package body Exp_Ch6 is function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is Actual : Node_Id; + function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id) + return Boolean; + -- Given a Dynamic_Predicate aspect aspecification for a + -- discrete type, returns True iff another DP specification + -- applies (indirectly, via a subtype type or a derived type) + -- to the same entity that this aspect spec applies to. + function May_Fold (N : Node_Id) return Traverse_Result; -- The predicate expression is foldable if it only contains operators -- and literals. During this check, we also replace occurrences of @@ -3150,6 +3157,36 @@ package body Exp_Ch6 is -- value of the actual. This is done on a copy of the analyzed -- expression for the predicate. + -------------------------------------- + -- Augments_Other_Dynamic_Predicate -- + -------------------------------------- + + function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id) + return Boolean + is + Aspect_Bearer : Entity_Id := Entity (DP_Aspect_Spec); + begin + loop + Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer); + + if not Present (Aspect_Bearer) then + return False; + end if; + + declare + Aspect_Spec : constant Node_Id := + Find_Aspect (Aspect_Bearer, Aspect_Dynamic_Predicate); + begin + if Present (Aspect_Spec) + and then Aspect_Spec /= DP_Aspect_Spec + then + -- Found another Dynamic_Predicate aspect spec + return True; + end if; + end; + end loop; + end Augments_Other_Dynamic_Predicate; + -------------- -- May_Fold -- -------------- @@ -3192,7 +3229,7 @@ package body Exp_Ch6 is function Try_Fold is new Traverse_Func (May_Fold); - -- Other lLocal variables + -- Other Local variables Subt : constant Entity_Id := Etype (First_Entity (P)); Aspect : Node_Id; @@ -3220,6 +3257,11 @@ package body Exp_Ch6 is or else Nkind (Actual) /= N_Integer_Literal or else not Has_Dynamic_Predicate_Aspect (Subt) or else No (Aspect) + + -- Do not fold if multiple applicable predicate aspects + or else Present (Find_Aspect (Subt, Aspect_Static_Predicate)) + or else Present (Find_Aspect (Subt, Aspect_Predicate)) + or else Augments_Other_Dynamic_Predicate (Aspect) or else CodePeer_Mode then return False; @@ -9665,7 +9707,9 @@ package body Exp_Ch6 is -- At this point, Defining_Identifier (Obj_Decl) is no longer equal -- to Obj_Def_Id. - Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); + pragma Assert (Ekind (Defining_Identifier (Obj_Decl)) = E_Void); + Set_Renamed_Object_Of_Possibly_Void + (Defining_Identifier (Obj_Decl), Call_Deref); -- If the original entity comes from source, then mark the new -- entity as needing debug information, even though it's defined diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 71cad98..cd9ff21 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3613,11 +3613,10 @@ package body Exp_Ch7 is and then (not Is_Library_Level_Entity (Spec_Id) - -- Nested packages are considered to be library level entities, - -- but do not need to be processed separately. True library level - -- packages have a scope value of 1. + -- Nested packages are library level entities, but do not need to + -- be processed separately. - or else Scope_Depth_Value (Spec_Id) /= Uint_1 + or else Scope_Depth (Spec_Id) /= Uint_1 or else (Is_Generic_Instance (Spec_Id) and then Package_Instantiation (Spec_Id) /= N)) @@ -8954,11 +8953,12 @@ package body Exp_Ch7 is Typ : Entity_Id; Skip_Self : Boolean := False) return Node_Id is - Loc : constant Source_Ptr := Sloc (Obj_Ref); - Atyp : Entity_Id; - Fin_Id : Entity_Id := Empty; - Ref : Node_Id; - Utyp : Entity_Id; + Loc : constant Source_Ptr := Sloc (Obj_Ref); + Atyp : Entity_Id; + Prot_Typ : Entity_Id := Empty; + Fin_Id : Entity_Id := Empty; + Ref : Node_Id; + Utyp : Entity_Id; begin Ref := Obj_Ref; @@ -9036,6 +9036,19 @@ package body Exp_Ch7 is Set_Assignment_OK (Ref); end if; + -- Detect if Typ is a protected type or an expanded protected type and + -- store the relevant type within Prot_Typ for later processing. + + if Is_Protected_Type (Typ) then + Prot_Typ := Typ; + + elsif Ekind (Typ) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Typ)) + and then Is_Protected_Type (Corresponding_Concurrent_Type (Typ)) + then + Prot_Typ := Corresponding_Concurrent_Type (Typ); + end if; + -- The underlying type may not be present due to a missing full view. In -- this case freezing did not take place and there is no [Deep_]Finalize -- primitive to call. @@ -9081,7 +9094,7 @@ package body Exp_Ch7 is -- Protected types: these also require finalization even though they -- are not marked controlled explicitly. - elsif Is_Protected_Type (Typ) then + elsif Present (Prot_Typ) then -- Protected objects do not need to be finalized on restricted -- runtimes. @@ -9091,7 +9104,7 @@ package body Exp_Ch7 is -- ??? Only handle the simple case for now. Will not support a record -- or array containing protected objects. - elsif Is_Simple_Protected_Type (Typ) then + elsif Is_Simple_Protected_Type (Prot_Typ) then Fin_Id := RTE (RE_Finalize_Protection); else raise Program_Error; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 96d78cc..19d546e 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -290,6 +290,11 @@ package body Exp_Dbug is -------------------------------- function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is + pragma Assert + (Nkind (N) in N_Object_Renaming_Declaration + | N_Package_Renaming_Declaration + | N_Exception_Renaming_Declaration); + Loc : constant Source_Ptr := Sloc (N); Ent : constant Node_Id := Defining_Entity (N); Nam : constant Node_Id := Name (N); @@ -410,7 +415,7 @@ package body Exp_Dbug is | N_Identifier => if No (Entity (Ren)) - or else not Present (Renamed_Object (Entity (Ren))) + or else not Present (Renamed_Entity_Or_Object (Entity (Ren))) then exit; end if; @@ -418,7 +423,7 @@ package body Exp_Dbug is -- This is a renaming of a renaming: traverse until the final -- renaming to see if anything is packed along the way. - Ren := Renamed_Object (Entity (Ren)); + Ren := Renamed_Entity_Or_Object (Entity (Ren)); when N_Selected_Component => declare diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 6ade54b..88f11b2 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3037,7 +3037,7 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- Null body is generated for interface types and non-concurrent + -- Null body is generated for interface types and nonconcurrent -- tagged types. if Is_Interface (Typ) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 9d9811b..f286763 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -373,9 +373,9 @@ package Exp_Disp is -- target object in its first argument; such implicit argument is explicit -- in the IP procedures built here. - procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint); - -- Set the position of a dispatching primitive its dispatch table. For - -- subprogram wrappers propagate the value to the wrapped subprogram. + procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint); + -- Set the position of a dispatching primitive in its dispatch table. + -- For subprogram wrappers propagate the value to the wrapped subprogram. procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id); -- Set the definite value of the DTC_Entity value associated with a given diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 5cb8fb5..41c0aea 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -300,12 +300,9 @@ package body Exp_Dist is NVList : Entity_Id; Parameter : Entity_Id; Constrained : Boolean; - RACW_Ctrl : Boolean := False; Any : Entity_Id) return Node_Id; -- Return a call to Add_Item to add the Any corresponding to the designated -- formal Parameter (with the indicated Constrained status) to NVList. - -- RACW_Ctrl must be set to True for controlling formals of distributed - -- object primitive operations. -------------------- -- Stub_Structure -- @@ -1089,7 +1086,6 @@ package body Exp_Dist is NVList : Entity_Id; Parameter : Entity_Id; Constrained : Boolean; - RACW_Ctrl : Boolean := False; Any : Entity_Id) return Node_Id is Parameter_Name_String : String_Id; @@ -1146,7 +1142,7 @@ package body Exp_Dist is Parameter_Name_String := String_From_Name_Buffer; - if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then + if Nkind (Parameter) = N_Defining_Identifier then -- When the parameter passed to Add_Parameter_To_NVList is an -- Extra_Constrained parameter, Parameter is an N_Defining_ diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 8d7624f..94a61df 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -190,6 +190,15 @@ package body Exp_Fixd is -- The expression returned is neither analyzed nor resolved. The Etype -- of the result is properly set (to Universal_Real). + function Get_Size_For_Value (V : Uint) return Pos; + -- Given a non-negative universal integer value, return the size of a small + -- signed integer type covering -V .. V, or Pos'Max if no such type exists. + + function Get_Type_For_Size (Siz : Pos; Force : Boolean) return Entity_Id; + -- Return the smallest signed integer type containing at least Siz bits. + -- If no such type exists, return Empty if Force is False or the largest + -- signed integer type if Force is True. + function Integer_Literal (N : Node_Id; V : Uint; @@ -324,7 +333,6 @@ package body Exp_Fixd is Right_Type : constant Entity_Id := Base_Type (Etype (R)); Left_Size : Int; Right_Size : Int; - Rsize : Int; Result_Type : Entity_Id; Rnode : Node_Id; @@ -354,20 +362,17 @@ package body Exp_Fixd is -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the - -- operand to get its size if it would fit in signed 8/16/32 bits. + -- operand to get a size if it would fit in a small signed integer. Left_Size := UI_To_Int (RM_Size (Left_Type)); if Compile_Time_Known_Value (L) then declare - Val : constant Uint := Expr_Value (L); + Siz : constant Int := + Get_Size_For_Value (UI_Abs (Expr_Value (L))); begin - if Val < Uint_2 ** 7 then - Left_Size := 8; - elsif Val < Uint_2 ** 15 then - Left_Size := 16; - elsif Val < Uint_2 ** 31 then - Left_Size := 32; + if Siz < Left_Size then + Left_Size := Siz; end if; end; end if; @@ -376,35 +381,19 @@ package body Exp_Fixd is if Compile_Time_Known_Value (R) then declare - Val : constant Uint := Expr_Value (R); + Siz : constant Int := + Get_Size_For_Value (UI_Abs (Expr_Value (R))); begin - if Val <= Int'(2 ** 7) then - Right_Size := 8; - elsif Val <= Int'(2 ** 15) then - Right_Size := 16; + if Siz < Right_Size then + Right_Size := Siz; end if; end; end if; -- Do the operation using the longer of the two sizes - Rsize := Int'Max (Left_Size, Right_Size); - - if Rsize <= 8 then - Result_Type := Standard_Integer_8; - - elsif Rsize <= 16 then - Result_Type := Standard_Integer_16; - - elsif Rsize <= 32 then - Result_Type := Standard_Integer_32; - - elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then - Result_Type := Standard_Integer_64; - - else - Result_Type := Standard_Integer_128; - end if; + Result_Type := + Get_Type_For_Size (Int'Max (Left_Size, Right_Size), Force => True); Rnode := Make_Op_Divide (Loc, @@ -664,7 +653,6 @@ package body Exp_Fixd is Right_Type : constant Entity_Id := Etype (R); Left_Size : Int; Right_Size : Int; - Rsize : Int; Result_Type : Entity_Id; Rnode : Node_Id; @@ -697,20 +685,17 @@ package body Exp_Fixd is -- the effective size of an operand is the RM_Size of the operand. -- But a special case arises with operands whose size is known at -- compile time. In this case, we can use the actual value of the - -- operand to get its size if it would fit in signed 8/16/32 bits. + -- operand to get a size if it would fit in a small signed integer. Left_Size := UI_To_Int (RM_Size (Left_Type)); if Compile_Time_Known_Value (L) then declare - Val : constant Uint := Expr_Value (L); + Siz : constant Int := + Get_Size_For_Value (UI_Abs (Expr_Value (L))); begin - if Val < Uint_2 ** 7 then - Left_Size := 8; - elsif Val < Uint_2 ** 15 then - Left_Size := 16; - elsif Val < Uint_2 ** 31 then - Left_Size := 32; + if Siz < Left_Size then + Left_Size := Siz; end if; end; end if; @@ -719,12 +704,11 @@ package body Exp_Fixd is if Compile_Time_Known_Value (R) then declare - Val : constant Uint := Expr_Value (R); + Siz : constant Int := + Get_Size_For_Value (UI_Abs (Expr_Value (R))); begin - if Val <= Int'(2 ** 7) then - Right_Size := 8; - elsif Val <= Int'(2 ** 15) then - Right_Size := 16; + if Siz < Right_Size then + Right_Size := Siz; end if; end; end if; @@ -732,23 +716,8 @@ package body Exp_Fixd is -- Now the result size must be at least the sum of the two sizes, -- to accommodate all possible results. - Rsize := Left_Size + Right_Size; - - if Rsize <= 8 then - Result_Type := Standard_Integer_8; - - elsif Rsize <= 16 then - Result_Type := Standard_Integer_16; - - elsif Rsize <= 32 then - Result_Type := Standard_Integer_32; - - elsif Rsize <= 64 or else System_Max_Integer_Size < 128 then - Result_Type := Standard_Integer_64; - - else - Result_Type := Standard_Integer_128; - end if; + Result_Type := + Get_Type_For_Size (Left_Size + Right_Size, Force => True); Rnode := Make_Op_Multiply (Loc, @@ -1542,7 +1511,7 @@ package body Exp_Fixd is else Lit_Int := Integer_Literal (N, Frac_Den, UR_Is_Negative (Frac)); - Lit_K := Integer_Literal (N, Frac_Num); + Lit_K := Integer_Literal (N, Frac_Num, False); if Present (Lit_Int) and then Present (Lit_K) then Set_Result (N, Build_Scaled_Divide (N, Left, Lit_K, Lit_Int)); @@ -2422,6 +2391,64 @@ package body Exp_Fixd is return Build_Conversion (N, Universal_Real, N); end Fpt_Value; + ------------------------ + -- Get_Size_For_Value -- + ------------------------ + + function Get_Size_For_Value (V : Uint) return Pos is + begin + pragma Assert (V >= Uint_0); + + if V < Uint_2 ** 7 then + return 8; + + elsif V < Uint_2 ** 15 then + return 16; + + elsif V < Uint_2 ** 31 then + return 32; + + elsif V < Uint_2 ** 63 then + return 64; + + elsif V < Uint_2 ** 127 then + return 128; + + else + return Pos'Last; + end if; + end Get_Size_For_Value; + + ----------------------- + -- Get_Type_For_Size -- + ----------------------- + + function Get_Type_For_Size (Siz : Pos; Force : Boolean) return Entity_Id is + begin + if Siz <= 8 then + return Standard_Integer_8; + + elsif Siz <= 16 then + return Standard_Integer_16; + + elsif Siz <= 32 then + return Standard_Integer_32; + + elsif Siz <= 64 + or else (Force and then System_Max_Integer_Size < 128) + then + return Standard_Integer_64; + + elsif (Siz <= 128 and then System_Max_Integer_Size = 128) + or else Force + then + return Standard_Integer_128; + + else + return Empty; + end if; + end Get_Type_For_Size; + --------------------- -- Integer_Literal -- --------------------- @@ -2435,22 +2462,8 @@ package body Exp_Fixd is L : Node_Id; begin - if V < Uint_2 ** 7 then - T := Standard_Integer_8; - - elsif V < Uint_2 ** 15 then - T := Standard_Integer_16; - - elsif V < Uint_2 ** 31 then - T := Standard_Integer_32; - - elsif V < Uint_2 ** 63 then - T := Standard_Integer_64; - - elsif V < Uint_2 ** 127 and then System_Max_Integer_Size = 128 then - T := Standard_Integer_128; - - else + T := Get_Type_For_Size (Get_Size_For_Value (V), Force => False); + if No (T) then return Empty; end if; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 86cb702..c139bb4 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -325,7 +325,7 @@ package body Exp_Intr is Result_Typ := Class_Wide_Type (Etype (Act_Constr)); -- Check that the accessibility level of the tag is no deeper than that - -- of the constructor function (unless CodePeer_Mode) + -- of the constructor function (unless CodePeer_Mode). if not CodePeer_Mode then Insert_Action (N, @@ -335,7 +335,8 @@ package body Exp_Intr is Left_Opnd => Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), Right_Opnd => - Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), + Make_Integer_Literal + (Loc, Scope_Depth_Default_0 (Act_Constr))), Then_Statements => New_List ( Make_Raise_Statement (Loc, diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 27b4e7d..f0b4b0b 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -563,9 +563,9 @@ package body Exp_Prag is null; elsif Nam = Name_Assert then - Error_Msg_N ("?A?assertion will fail at run time", N); + Error_Msg_N ("?.a?assertion will fail at run time", N); else - Error_Msg_N ("?A?check will fail at run time", N); + Error_Msg_N ("?.a?check will fail at run time", N); end if; end if; end Expand_Pragma_Check; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index bbfee62..bce745b 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -451,6 +451,7 @@ package body Exp_SPARK is Apply_Universal_Integer_Attribute_Checks (N); if Present (Typ) + and then Known_RM_Size (Typ) and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer) then -- ??? This should rather be a range check, but this would diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index c87b881..8983dab1c 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -624,7 +624,7 @@ package body Exp_Strm is end if; else pragma Assert (Is_Access_Type (U_Type)); - if P_Size > System_Address_Size then + if Present (P_Size) and then P_Size > System_Address_Size then Lib_RE := RE_I_AD; else Lib_RE := RE_I_AS; @@ -868,7 +868,7 @@ package body Exp_Strm is else pragma Assert (Is_Access_Type (U_Type)); - if P_Size > System_Address_Size then + if Present (P_Size) and then P_Size > System_Address_Size then Lib_RE := RE_W_AD; else Lib_RE := RE_W_AS; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c071a9c..be06580 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -270,7 +270,9 @@ package body Exp_Unst is begin pragma Assert (Is_Subprogram (E)); - if Subps_Index (E) = Uint_0 then + if Field_Is_Initial_Zero (E, F_Subps_Index) + or else Subps_Index (E) = Uint_0 + then E := Ultimate_Alias (E); -- The body of a protected operation has a different name and @@ -886,6 +888,7 @@ package body Exp_Unst is if Is_Subprogram (Ent) and then not Is_Generic_Subprogram (Ent) and then not Is_Imported (Ent) + and then not Is_Intrinsic_Subprogram (Ent) and then Scope_Within (Ultimate_Alias (Ent), Subp) then Append_Unique_Call ((N, Current_Subprogram, Ent)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index cb18096..b0ea44a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -315,10 +315,10 @@ package body Exp_Util is if Present (Msg_Node) then Error_Msg_N - ("info: atomic synchronization set for &?N?", Msg_Node); + ("info: atomic synchronization set for &?.n?", Msg_Node); else Error_Msg_N - ("info: atomic synchronization set?N?", N); + ("info: atomic synchronization set?.n?", N); end if; end if; end Activate_Atomic_Synchronization; @@ -1293,7 +1293,7 @@ package body Exp_Util is Adjust_Inherited_Pragma_Sloc (N); end if; - if Nkind (N) in N_Identifier | N_Operator_Symbol + if Nkind (N) in N_Identifier | N_Expanded_Name | N_Operator_Symbol and then Present (Entity (N)) and then (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) @@ -2849,7 +2849,7 @@ package body Exp_Util is if Inherited and Opt.List_Inherited_Aspects then Error_Msg_Sloc := Sloc (Prag); Error_Msg_N - ("info: & inherits `Invariant''Class` aspect from #?L?", Typ); + ("info: & inherits `Invariant''Class` aspect from #?.l?", Typ); end if; -- Add the pragma to the list of processed pragmas @@ -4784,7 +4784,8 @@ package body Exp_Util is -- record or bit-packed array, then everything is fine, since the back -- end can handle these cases correctly. - elsif Esize (Comp) <= System_Max_Integer_Size + elsif Known_Esize (Comp) + and then Esize (Comp) <= System_Max_Integer_Size and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT)) then return False; @@ -7619,8 +7620,18 @@ package body Exp_Util is | N_Iterated_Component_Association | N_Iterated_Element_Association => - if Nkind (Parent (P)) = N_Aggregate - and then Present (Loop_Actions (P)) + if Nkind (Parent (P)) in N_Aggregate | N_Delta_Aggregate + + -- We must not climb up out of an N_Iterated_xxx_Association + -- because the actions might contain references to the loop + -- parameter. But it turns out that setting the Loop_Actions + -- attribute in the case of an N_Component_Association + -- when the attribute was not already set can lead to + -- (as yet not understood) bugboxes (gcc failures that are + -- presumably due to malformed trees). So we don't do that. + + and then (Nkind (P) /= N_Component_Association + or else Present (Loop_Actions (P))) then if Is_Empty_List (Loop_Actions (P)) then Set_Loop_Actions (P, Ins_Actions); @@ -7994,10 +8005,8 @@ package body Exp_Util is ---------------------- function Inside_Init_Proc return Boolean is - Proc : constant Entity_Id := Enclosing_Init_Proc; - begin - return Proc /= Empty; + return Present (Enclosing_Init_Proc); end Inside_Init_Proc; ---------------------- @@ -11248,6 +11257,7 @@ package body Exp_Util is when others => if Is_Entity_Name (N) + and then Is_Object (Entity (N)) and then Present (Renamed_Object (Entity (N))) then return diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index e0483b7..75c0edb 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -49,6 +49,7 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; +with Stand; use Stand; with Table; package body Expander is @@ -152,7 +153,19 @@ package body Expander is -- not take place. This prevents cascaded errors due to stack mismatch. elsif not Expander_Active then - Set_Analyzed (N, Full_Analysis); + + -- Do not clear the Analyzed flag if it has been set on purpose + -- during preanalysis in Fold_Ureal. In that case, the Etype field + -- in N_Real_Literal will be set to something different than + -- Universal_Real. + + if Full_Analysis + or else not (Nkind (N) = N_Real_Literal + and then Present (Etype (N)) + and then Etype (N) /= Universal_Real) + then + Set_Analyzed (N, Full_Analysis); + end if; if Serious_Errors_Detected > 0 and then Scope_Is_Transient then Scope_Stack.Table diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 957f40b..67cc218 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -260,6 +260,8 @@ extern Boolean Back_End_Exceptions (void); restrict__check_no_implicit_task_alloc #define No_Exception_Handlers_Set \ restrict__no_exception_handlers_set +#define No_Exception_Propagation_Active \ + restrict__no_exception_propagation_active extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); @@ -267,6 +269,7 @@ extern void Check_No_Implicit_Heap_Alloc (Node_Id); extern void Check_No_Implicit_Protected_Alloc (Node_Id); extern void Check_No_Implicit_Task_Alloc (Node_Id); extern Boolean No_Exception_Handlers_Set (void); +extern Boolean No_Exception_Propagation_Active (void); /* sem_aggr: */ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5f81d9e..97a51db 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -865,9 +865,12 @@ package body Freeze is Error_Msg_NE (Size_Too_Small_Message, Size_Clause (T), T); end if; - -- Set size if not set already + -- Set size if not set already. Do not set it to Uint_0, because in + -- some cases (notably array-of-record), the Component_Size is + -- No_Uint, which causes S to be Uint_0. Presumably the RM_Size and + -- Component_Size will eventually be set correctly by the back end. - elsif not Known_RM_Size (T) then + elsif not Known_RM_Size (T) and then S /= Uint_0 then Set_RM_Size (T, S); end if; end Set_Small_Size; @@ -899,8 +902,17 @@ package body Freeze is -- String literals always have known size, and we can set it if Ekind (T) = E_String_Literal_Subtype then - Set_Small_Size - (T, Component_Size (T) * String_Literal_Length (T)); + if Known_Component_Size (T) then + Set_Small_Size + (T, Component_Size (T) * String_Literal_Length (T)); + + else + -- The following is wrong, but does what previous versions + -- did. The Component_Size is unknown for the string in a + -- pragma Warnings. + Set_Small_Size (T, Uint_0); + end if; + return True; -- Unconstrained types never have known at compile time size @@ -932,6 +944,12 @@ package body Freeze is Dim : Uint; begin + -- See comment in Set_Small_Size above + + if No (Size) then + Size := Uint_0; + end if; + Index := First_Index (T); while Present (Index) loop if Nkind (Index) = N_Range then @@ -954,7 +972,7 @@ package body Freeze is else Dim := Expr_Value (High) - Expr_Value (Low) + 1; - if Dim >= 0 then + if Dim > Uint_0 then Size := Size * Dim; else Size := Uint_0; @@ -2319,7 +2337,7 @@ package body Freeze is -- created for entry parameters must be frozen. if Ekind (E) = E_Package - and then No (Renamed_Object (E)) + and then No (Renamed_Entity (E)) and then not Is_Child_Unit (E) and then not Is_Frozen (E) then @@ -3353,7 +3371,7 @@ package body Freeze is Error_Msg_Uint_1 := Modv; Error_Msg_N - ("?M?2 '*'*^' may have been intended here", + ("?.m?2 '*'*^' may have been intended here", Modulus); end; end if; @@ -3703,6 +3721,7 @@ package body Freeze is if Has_Pragma_Pack (Arr) and then not Present (Comp_Size_C) and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then Known_Esize (Base_Type (Ctyp)) and then Esize (Base_Type (Ctyp)) = Csiz + 1 then Error_Msg_Uint_1 := Csiz; @@ -6393,7 +6412,7 @@ package body Freeze is then Error_Msg_NE ("useless postcondition, & is marked " - & "No_Return?T?", Exp, E); + & "No_Return?.t?", Exp, E); end if; end if; @@ -6646,7 +6665,7 @@ package body Freeze is Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1; - if Dim >= 0 then + if Dim > Uint_0 then Num_Elmts := Num_Elmts * Dim; else Num_Elmts := Uint_0; @@ -6668,9 +6687,12 @@ package body Freeze is if Implicit_Packing then Set_Component_Size (Btyp, Rsiz); - -- Otherwise give an error message + -- Otherwise give an error message, except that if the + -- specified Size is zero, there is no need for pragma + -- Pack. Note that size zero is not considered + -- Addressable. - else + elsif RM_Size (E) /= Uint_0 then Error_Msg_NE ("size given for& too small", SZ, E); Error_Msg_N -- CODEFIX @@ -6771,24 +6793,24 @@ package body Freeze is if Sloc (SC) > Sloc (AC) then Loc := SC; Error_Msg_NE - ("?Z?size is not a multiple of alignment for &", + ("?.z?size is not a multiple of alignment for &", Loc, E); Error_Msg_Sloc := Sloc (AC); Error_Msg_Uint_1 := Alignment (E); - Error_Msg_N ("\?Z?alignment of ^ specified #", Loc); + Error_Msg_N ("\?.z?alignment of ^ specified #", Loc); else Loc := AC; Error_Msg_NE - ("?Z?size is not a multiple of alignment for &", + ("?.z?size is not a multiple of alignment for &", Loc, E); Error_Msg_Sloc := Sloc (SC); Error_Msg_Uint_1 := RM_Size (E); - Error_Msg_N ("\?Z?size of ^ specified #", Loc); + Error_Msg_N ("\?.z?size of ^ specified #", Loc); end if; Error_Msg_Uint_1 := ((RM_Size (E) / Abits) + 1) * Abits; - Error_Msg_N ("\?Z?Object_Size will be increased to ^", Loc); + Error_Msg_N ("\?.z?Object_Size will be increased to ^", Loc); end if; end; end if; @@ -9478,9 +9500,7 @@ package body Freeze is Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); begin - if Known_RM_Size (Typ) - and then RM_Size (Typ) /= Uint_0 - then + if Known_RM_Size (Typ) then if RM_Size (Typ) < Minsiz then Error_Msg_Uint_1 := RM_Size (Typ); Error_Msg_Uint_2 := Minsiz; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 61a627f..ba194d1 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -116,7 +116,7 @@ ADA_FLAGS_TO_PASS = \ # List of Ada tools to build and install ADA_TOOLS=gnatbind gnatchop gnat gnatkr gnatlink gnatls gnatmake \ - gnatname gnatprep gnatxref gnatfind gnatclean + gnatname gnatprep gnatclean # Say how to compile Ada programs. .SUFFIXES: .ada .adb .ads @@ -838,8 +838,20 @@ ada.install-info: $(DESTDIR)$(infodir)/gnat_ugn.info \ $(DESTDIR)$(infodir)/gnat_rm.info \ $(DESTDIR)$(infodir)/gnat-style.info -ada.dvi: doc/gnat_ugn.dvi \ - doc/gnat_rm.dvi doc/gnat-style.dvi +ADA_DVIFILES = doc/gnat_ugn.dvi \ + doc/gnat_rm.dvi doc/gnat-style.dvi + +ada.dvi: $(ADA_DVIFILES) + +ada.install-dvi: $(ADA_DVIFILES) + @$(NORMAL_INSTALL) + test -z "$(dvidir)/gcc" || $(mkinstalldirs) "$(DESTDIR)$(dvidir)/gcc" + @list='$(ADA_DVIFILES)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(dvi__strip_dir) \ + echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(dvidir)/gcc/$$f'"; \ + $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(dvidir)/gcc/$$f"; \ + done ADA_PDFFILES = doc/gnat_ugn.pdf \ doc/gnat_rm.pdf doc/gnat-style.pdf @@ -891,8 +903,7 @@ doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi # (cross). $(prefix) comes from the --program-prefix configure option, # or from the --target option if the former is not specified. # Do the same for the rest of the Ada tools (gnatchop, gnat, gnatkr, -# gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatxref, gnatfind, -# gnatclean). +# gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatclean). # gnatdll is only used on Windows. ada.install-common: $(gnat_install_lib) gnat-install-tools @@ -963,8 +974,6 @@ ada.distclean: -$(RM) gnatmake$(exeext) -$(RM) gnatname$(exeext) -$(RM) gnatprep$(exeext) - -$(RM) gnatfind$(exeext) - -$(RM) gnatxref$(exeext) -$(RM) gnatclean$(exeext) -$(RM) ada/rts/* -$(RMDIR) ada/rts diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 4ab71977..9df8809 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -449,7 +449,7 @@ gnattools2: ../stamp-tools common-tools: ../stamp-tools $(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \ --GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \ - gnatchop gnatcmd gnatkr gnatls gnatprep gnatxref gnatfind gnatname \ + gnatchop gnatcmd gnatkr gnatls gnatprep gnatname \ gnatclean -bargs $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATLINK) -v gnatcmd -o ../../gnat$(exeext) \ --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) @@ -461,10 +461,6 @@ common-tools: ../stamp-tools --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) $(GNATLINK) -v gnatprep -o ../../gnatprep$(exeext) \ --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) - $(GNATLINK) -v gnatxref -o ../../gnatxref$(exeext) \ - --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) - $(GNATLINK) -v gnatfind -o ../../gnatfind$(exeext) \ - --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) $(GNATLINK) -v gnatname -o ../../gnatname$(exeext) \ --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) $(GNATLINK) -v gnatclean -o ../../gnatclean$(exeext) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 13e9004..98b4aaf 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -239,8 +239,10 @@ static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool, const char *, const char *); static void set_rm_size (Uint, tree, Entity_Id); static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); -static unsigned int promote_object_alignment (tree, Entity_Id); +static unsigned int promote_object_alignment (tree, tree, Entity_Id); static void check_ok_for_atomic_type (tree, Entity_Id, bool); +static bool type_for_atomic_builtin_p (tree); +static tree resolve_atomic_builtin (enum built_in_function, tree); static tree create_field_decl_from (tree, tree, tree, tree, tree, vec<subst_pair>); static tree create_rep_part (tree, tree, tree); @@ -897,7 +899,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) or a reference to another object, and the size of its type is a constant, set the alignment to the smallest one which is not smaller than the size, with an appropriate cap. */ - if (!gnu_size && align == 0 + if (!Known_Esize (gnat_entity) + && !Known_Alignment (gnat_entity) && (Is_Full_Access (gnat_entity) || (!Optimize_Alignment_Space (gnat_entity) && kind != E_Exception @@ -908,8 +911,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !imported_p && No (gnat_renamed_obj) && No (Address_Clause (gnat_entity)))) - && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) - align = promote_object_alignment (gnu_type, gnat_entity); + && (TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST || gnu_size)) + align = promote_object_alignment (gnu_type, gnu_size, gnat_entity); /* If the object is set to have atomic components, find the component type and validate it. @@ -3943,7 +3946,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) bool extern_flag = ((Is_Public (gnat_entity) && !definition) || imported_p - || (Convention (gnat_entity) == Convention_Intrinsic + || (Is_Intrinsic_Subprogram (gnat_entity) && Has_Pragma_Inline_Always (gnat_entity))); tree gnu_param_list; @@ -4487,7 +4490,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Likewise for the RM size, if any. */ if (!Known_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type)) Set_RM_Size (gnat_entity, - No_Uint_To_0 (annotate_value (rm_size (gnu_type)))); + annotate_value (rm_size (gnu_type))); /* If we are at global level, GCC applied variable_size to the size but this has done nothing. So, if it's not constant or self-referential, @@ -5363,7 +5366,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, /* Builtins are expanded inline and there is no real call sequence involved. So the type expected by the underlying expander is always the type of the argument "as is". */ - if (Convention (gnat_subprog) == Convention_Intrinsic + if (Is_Intrinsic_Subprogram (gnat_subprog) && Present (Interface_Name (gnat_subprog))) mech = By_Copy; @@ -5403,19 +5406,21 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, mech = Default; } - /* If this is either a foreign function or if the underlying type won't - be passed by reference and is as aligned as the original type, strip - off possible padding type. */ + /* Either for foreign conventions, or if the underlying type is not passed + by reference and is as large and aligned as the original type, strip off + a possible padding type. */ if (TYPE_IS_PADDING_P (gnu_param_type)) { - tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); + tree inner_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); if (foreign || (mech != By_Reference - && !must_pass_by_ref (unpadded_type) - && (mech == By_Copy || !default_pass_by_ref (unpadded_type)) - && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type))) - gnu_param_type = unpadded_type; + && !must_pass_by_ref (inner_type) + && (mech == By_Copy || !default_pass_by_ref (inner_type)) + && ((TYPE_SIZE (inner_type) == TYPE_SIZE (gnu_param_type) + && TYPE_ALIGN (inner_type) >= TYPE_ALIGN (gnu_param_type)) + || Is_Init_Proc (gnat_subprog)))) + gnu_param_type = inner_type; } /* For foreign conventions, pass arrays as pointers to the element type. @@ -5818,9 +5823,10 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, else { - /* For foreign convention subprograms, return System.Address as void * - or equivalent. Note that this comprises GCC builtins. */ - if (Has_Foreign_Convention (gnat_subprog) + /* For foreign convention/intrinsic subprograms, return System.Address + as void * or equivalent; this comprises GCC builtins. */ + if ((Has_Foreign_Convention (gnat_subprog) + || Is_Intrinsic_Subprogram (gnat_subprog)) && Is_Descendant_Of_Address (Underlying_Type (gnat_return_type))) gnu_return_type = ptr_type_node; else @@ -5990,9 +5996,10 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, { Entity_Id gnat_param_type = Etype (gnat_param); - /* For foreign convention subprograms, pass System.Address as void * - or equivalent. Note that this comprises GCC builtins. */ - if (Has_Foreign_Convention (gnat_subprog) + /* For foreign convention/intrinsic subprograms, pass System.Address + as void * or equivalent; this comprises GCC builtins. */ + if ((Has_Foreign_Convention (gnat_subprog) + || Is_Intrinsic_Subprogram (gnat_subprog)) && Is_Descendant_Of_Address (Underlying_Type (gnat_param_type))) gnu_param_type = ptr_type_node; else @@ -6298,7 +6305,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, /* If this subprogram is expectedly bound to a GCC builtin, fetch the corresponding DECL node and check the parameter association. */ - if (Convention (gnat_subprog) == Convention_Intrinsic + if (Is_Intrinsic_Subprogram (gnat_subprog) && Present (Interface_Name (gnat_subprog))) { tree gnu_ext_name = create_concat_name (gnat_subprog, NULL); @@ -6309,14 +6316,106 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, the checker is expected to post diagnostics in this case. */ if (gnu_builtin_decl) { - const intrin_binding_t inb - = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) }; - - if (!intrin_profiles_compatible_p (&inb)) - post_error - ("??profile of& doesn''t match the builtin it binds!", - gnat_subprog); - return gnu_builtin_decl; + if (fndecl_built_in_p (gnu_builtin_decl, BUILT_IN_NORMAL)) + { + const enum built_in_function fncode + = DECL_FUNCTION_CODE (gnu_builtin_decl); + + switch (fncode) + { + case BUILT_IN_SYNC_FETCH_AND_ADD_N: + case BUILT_IN_SYNC_FETCH_AND_SUB_N: + case BUILT_IN_SYNC_FETCH_AND_OR_N: + case BUILT_IN_SYNC_FETCH_AND_AND_N: + case BUILT_IN_SYNC_FETCH_AND_XOR_N: + case BUILT_IN_SYNC_FETCH_AND_NAND_N: + case BUILT_IN_SYNC_ADD_AND_FETCH_N: + case BUILT_IN_SYNC_SUB_AND_FETCH_N: + case BUILT_IN_SYNC_OR_AND_FETCH_N: + case BUILT_IN_SYNC_AND_AND_FETCH_N: + case BUILT_IN_SYNC_XOR_AND_FETCH_N: + case BUILT_IN_SYNC_NAND_AND_FETCH_N: + case BUILT_IN_SYNC_VAL_COMPARE_AND_SWAP_N: + case BUILT_IN_SYNC_LOCK_TEST_AND_SET_N: + case BUILT_IN_ATOMIC_EXCHANGE_N: + case BUILT_IN_ATOMIC_LOAD_N: + case BUILT_IN_ATOMIC_ADD_FETCH_N: + case BUILT_IN_ATOMIC_SUB_FETCH_N: + case BUILT_IN_ATOMIC_AND_FETCH_N: + case BUILT_IN_ATOMIC_NAND_FETCH_N: + case BUILT_IN_ATOMIC_XOR_FETCH_N: + case BUILT_IN_ATOMIC_OR_FETCH_N: + case BUILT_IN_ATOMIC_FETCH_ADD_N: + case BUILT_IN_ATOMIC_FETCH_SUB_N: + case BUILT_IN_ATOMIC_FETCH_AND_N: + case BUILT_IN_ATOMIC_FETCH_NAND_N: + case BUILT_IN_ATOMIC_FETCH_XOR_N: + case BUILT_IN_ATOMIC_FETCH_OR_N: + /* This is a generic builtin overloaded on its return + type, so do type resolution based on it. */ + if (!VOID_TYPE_P (gnu_return_type) + && type_for_atomic_builtin_p (gnu_return_type)) + gnu_builtin_decl + = resolve_atomic_builtin (fncode, gnu_return_type); + else + { + post_error + ("??cannot import type-generic 'G'C'C builtin!", + gnat_subprog); + post_error + ("\\?use a supported result type", + gnat_subprog); + gnu_builtin_decl = NULL_TREE; + } + break; + + case BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N: + /* This is a generic builtin overloaded on its third + parameter type, so do type resolution based on it. */ + if (list_length (gnu_param_type_list) >= 4 + && type_for_atomic_builtin_p + (list_third (gnu_param_type_list))) + gnu_builtin_decl + = resolve_atomic_builtin + (fncode, list_third (gnu_param_type_list)); + else + { + post_error + ("??cannot import type-generic 'G'C'C builtin!", + gnat_subprog); + post_error + ("\\?use a supported third parameter type", + gnat_subprog); + gnu_builtin_decl = NULL_TREE; + } + break; + + case BUILT_IN_SYNC_BOOL_COMPARE_AND_SWAP_N: + case BUILT_IN_SYNC_LOCK_RELEASE_N: + case BUILT_IN_ATOMIC_STORE_N: + post_error + ("??unsupported type-generic 'G'C'C builtin!", + gnat_subprog); + gnu_builtin_decl = NULL_TREE; + break; + + default: + break; + } + } + + if (gnu_builtin_decl) + { + const intrin_binding_t inb + = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) }; + + if (!intrin_profiles_compatible_p (&inb)) + post_error + ("??profile of& doesn''t match the builtin it binds!", + gnat_subprog); + + return gnu_builtin_decl; + } } /* Inability to find the builtin DECL most often indicates a genuine @@ -6326,7 +6425,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, on demand without risking false positives with common default sets of options. */ if (warn_shadow) - post_error ("'G'C'C intrinsic not found for&!??", gnat_subprog); + post_error ("'G'C'C builtin not found for&!??", gnat_subprog); } } @@ -7320,7 +7419,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, if (Is_Full_Access (gnat_field)) { const unsigned int align - = promote_object_alignment (gnu_field_type, gnat_field); + = promote_object_alignment (gnu_field_type, NULL_TREE, gnat_field); if (align > 0) gnu_field_type = maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field, @@ -9391,11 +9490,11 @@ validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) return align; } -/* Promote the alignment of GNU_TYPE corresponding to GNAT_ENTITY. Return - a positive value on success or zero on failure. */ +/* Promote the alignment of GNU_TYPE for an object with GNU_SIZE corresponding + to GNAT_ENTITY. Return a positive value on success or zero on failure. */ static unsigned int -promote_object_alignment (tree gnu_type, Entity_Id gnat_entity) +promote_object_alignment (tree gnu_type, tree gnu_size, Entity_Id gnat_entity) { unsigned int align, size_cap, align_cap; @@ -9416,14 +9515,17 @@ promote_object_alignment (tree gnu_type, Entity_Id gnat_entity) align_cap = get_mode_alignment (ptr_mode); } + if (!gnu_size) + gnu_size = TYPE_SIZE (gnu_type); + /* Do the promotion within the above limits. */ - if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type)) - || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0) + if (!tree_fits_uhwi_p (gnu_size) + || compare_tree_int (gnu_size, size_cap) > 0) align = 0; - else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0) + else if (compare_tree_int (gnu_size, align_cap) > 0) align = align_cap; else - align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type))); + align = ceil_pow2 (tree_to_uhwi (gnu_size)); /* But make sure not to under-align the object. */ if (align <= TYPE_ALIGN (gnu_type)) @@ -9506,6 +9608,33 @@ check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p) gnat_error_point, gnat_entity); } +/* Return true if TYPE is suitable for a type-generic atomic builtin. */ + +static bool +type_for_atomic_builtin_p (tree type) +{ + const enum machine_mode mode = TYPE_MODE (type); + if (GET_MODE_CLASS (mode) == MODE_FLOAT) + return true; + + scalar_int_mode imode; + if (is_a <scalar_int_mode> (mode, &imode) && GET_MODE_SIZE (imode) <= 16) + return true; + + return false; +} + +/* Return the GCC atomic builtin based on CODE and sized for TYPE. */ + +static tree +resolve_atomic_builtin (enum built_in_function code, tree type) +{ + const unsigned int size = resolve_atomic_size (type); + code = (enum built_in_function) ((int) code + exact_log2 (size) + 1); + + return builtin_decl_implicit (code); +} + /* Helper for intrin_profiles_compatible_p, to perform compatibility checks on the Ada/builtin argument lists for the INB binding. */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 692ef44..1b55ec5 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1026,6 +1026,9 @@ extern Entity_Id get_debug_scope (Node_Id gnat_node, bool *is_subprogram); should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */ extern bool can_materialize_object_renaming_p (Node_Id expr); +/* Return the size of TYPE, which must be a positive power of 2. */ +extern unsigned int resolve_atomic_size (tree type); + #ifdef __cplusplus extern "C" { #endif @@ -1223,3 +1226,11 @@ operand_type (tree expr) { return TREE_TYPE (TREE_OPERAND (expr, 0)); } + +/* Return the third value of a list. */ + +static inline tree +list_third (tree list) +{ + return TREE_VALUE (TREE_CHAIN (TREE_CHAIN (list))); +} diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 96199bd..2caa83f 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -271,15 +271,9 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) warn_stringop_overflow = 0; /* No caret by default for Ada. */ - if (!global_options_set.x_flag_diagnostics_show_caret) + if (!OPTION_SET_P (flag_diagnostics_show_caret)) global_dc->show_caret = false; - /* Warn only if STABS is not the default: we don't want to emit a warning if - the user did not use a -gstabs option. */ - if (PREFERRED_DEBUGGING_TYPE != DBX_DEBUG && write_symbols == DBX_DEBUG) - warning (0, "STABS debugging information for Ada is obsolete and not " - "supported anymore"); - /* Copy global settings to local versions. */ gnat_encodings = global_options.x_gnat_encodings; optimize = global_options.x_optimize; @@ -422,12 +416,12 @@ gnat_init_gcc_eh (void) flag_delete_dead_exceptions = 1; if (Suppress_Checks) { - if (!global_options_set.x_flag_non_call_exceptions) + if (!OPTION_SET_P (flag_non_call_exceptions)) flag_non_call_exceptions = Machine_Overflows_On_Target && GNAT_Mode; } else { - if (!global_options_set.x_flag_non_call_exceptions) + if (!OPTION_SET_P (flag_non_call_exceptions)) flag_non_call_exceptions = 1; flag_aggressive_loop_optimizations = 0; warn_aggressive_loop_optimizations = 0; @@ -445,14 +439,14 @@ gnat_init_gcc_fp (void) S'Signed_Zeros is true, but don't override the user if not. */ if (Signed_Zeros_On_Target) flag_signed_zeros = 1; - else if (!global_options_set.x_flag_signed_zeros) + else if (!OPTION_SET_P (flag_signed_zeros)) flag_signed_zeros = 0; /* Assume that FP operations can trap if S'Machine_Overflow is true, but don't override the user if not. */ if (Machine_Overflows_On_Target) flag_trapping_math = 1; - else if (!global_options_set.x_flag_trapping_math) + else if (!OPTION_SET_P (flag_trapping_math)) flag_trapping_math = 0; } diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3fec060..dc2a03c 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7872,21 +7872,24 @@ gnat_to_gnu (Node_Id gnat_node) case N_Pop_Constraint_Error_Label: gnat_temp = gnu_constraint_error_label_stack.pop (); if (Present (gnat_temp) - && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))) + && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)) + && No_Exception_Propagation_Active ()) Warn_If_No_Local_Raise (gnat_temp); break; case N_Pop_Storage_Error_Label: gnat_temp = gnu_storage_error_label_stack.pop (); if (Present (gnat_temp) - && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))) + && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)) + && No_Exception_Propagation_Active ()) Warn_If_No_Local_Raise (gnat_temp); break; case N_Pop_Program_Error_Label: gnat_temp = gnu_program_error_label_stack.pop (); if (Present (gnat_temp) - && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))) + && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)) + && No_Exception_Propagation_Active ()) Warn_If_No_Local_Raise (gnat_temp); break; @@ -9076,7 +9079,7 @@ elaborate_all_entities_for_package (Entity_Id gnat_package) continue; /* Skip stuff internal to the compiler. */ - if (Convention (gnat_entity) == Convention_Intrinsic) + if (Is_Intrinsic_Subprogram (gnat_entity)) continue; if (kind == E_Operator) continue; diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index e8ed4b2..06d8203 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -663,7 +663,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, /* Return the size of TYPE, which must be a positive power of 2. */ -static unsigned int +unsigned int resolve_atomic_size (tree type) { unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE_UNIT (type)); diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 1fa7f0b..d91faaa 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -252,7 +252,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Contract, Node_Id), Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Original_Record_Component, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag), Sm (Current_Value, Node_Id), -- setter only @@ -607,7 +607,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- this is the first named subtype). Ab (Decimal_Fixed_Point_Kind, Fixed_Point_Kind, - (Sm (Digits_Value, Uint), + (Sm (Digits_Value, Upos), Sm (Has_Machine_Radix_Clause, Flag), Sm (Machine_Radix_10, Flag), Sm (Scale_Value, Uint))); @@ -623,7 +623,7 @@ begin -- Gen_IL.Gen.Gen_Entities -- first named subtype). Ab (Float_Kind, Real_Kind, - (Sm (Digits_Value, Uint))); + (Sm (Digits_Value, Upos))); Cc (E_Floating_Point_Type, Float_Kind); -- Floating point type, used for the anonymous base type of the @@ -866,23 +866,23 @@ begin -- Gen_IL.Gen.Gen_Entities -- A private type, created by a private type declaration that has -- neither the keyword limited nor the keyword tagged. (Sm (Scalar_Range, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Private_Subtype, Private_Kind, -- A subtype of a private type, created by a subtype declaration used -- to declare a subtype of a private type. - (Sm (Scope_Depth_Value, Uint))); + (Sm (Scope_Depth_Value, Unat))); Cc (E_Limited_Private_Type, Private_Kind, -- A limited private type, created by a private type declaration that -- has the keyword limited, but not the keyword tagged. (Sm (Scalar_Range, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Limited_Private_Subtype, Private_Kind, -- A subtype of a limited private type, created by a subtype declaration -- used to declare a subtype of a limited private type. - (Sm (Scope_Depth_Value, Uint))); + (Sm (Scope_Depth_Value, Unat))); Ab (Incomplete_Kind, Incomplete_Or_Private_Kind, (Sm (Non_Limited_View, Node_Id))); @@ -900,7 +900,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (First_Entity, Node_Id), Sm (First_Private_Entity, Node_Id), Sm (Last_Entity, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (Stored_Constraint, Elist_Id))); Ab (Task_Kind, Concurrent_Kind, @@ -1005,11 +1005,11 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Linker_Section_Pragma, Node_Id), Sm (Overridden_Operation, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (Static_Call_Helper, Node_Id), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag), - Sm (Subps_Index, Uint))); + Sm (Subps_Index, Unat))); Cc (E_Function, Subprogram_Kind, -- A function, created by a function declaration or a function body @@ -1137,7 +1137,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Postconditions_Proc, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1164,7 +1164,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1178,7 +1178,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), Sm (Return_Applies_To, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Entry_Index_Parameter, Entity_Kind, -- An entry index parameter created by an entry index specification @@ -1209,7 +1209,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); @@ -1254,7 +1254,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Loop_Entry_Attributes, Flag), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Return_Statement, Entity_Kind, -- A dummy entity created for each return statement. Used to hold @@ -1266,7 +1266,7 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (First_Entity, Node_Id), Sm (Last_Entity, Node_Id), Sm (Return_Applies_To, Node_Id), - Sm (Scope_Depth_Value, Uint))); + Sm (Scope_Depth_Value, Unat))); Cc (E_Package, Entity_Kind, -- A package, created by a package declaration @@ -1303,7 +1303,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Related_Instance, Node_Id), Sm (Renamed_In_Spec, Flag), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Aux_Pragma, Node_Id), Sm (SPARK_Aux_Pragma_Inherited, Flag), Sm (SPARK_Pragma, Node_Id), @@ -1323,7 +1323,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Last_Entity, Node_Id), Sm (Related_Instance, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Aux_Pragma, Node_Id), Sm (SPARK_Aux_Pragma_Inherited, Flag), Sm (SPARK_Pragma, Node_Id), @@ -1358,7 +1358,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Interface_Name, Node_Id), Sm (Last_Entity, Node_Id), Sm (Renamed_Or_Alias, Node_Id), - Sm (Scope_Depth_Value, Uint), + Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag))); diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 20d25ea..7125773 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -984,7 +984,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Case_Statement, N_Statement_Other_Than_Procedure_Call, (Sy (Expression, Node_Id, Default_Empty), Sy (Alternatives, List_Id, Default_No_List), - Sy (End_Span, Uint, Default_Uint_0), + Sy (End_Span, Unat, Default_Uint_0), Sm (From_Conditional_Expression, Flag))); Cc (N_Code_Statement, N_Statement_Other_Than_Procedure_Call, @@ -1094,7 +1094,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Then_Statements, List_Id), Sy (Elsif_Parts, List_Id, Default_No_List), Sy (Else_Statements, List_Id, Default_No_List), - Sy (End_Span, Uint, Default_Uint_0), + Sy (End_Span, Unat, Default_Uint_0), Sm (From_Conditional_Expression, Flag))); Cc (N_Accept_Alternative, Node_Kind, @@ -1594,7 +1594,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Dcheck_Function, Node_Id), Sm (Enclosing_Variant, Node_Id), Sm (Has_SP_Choice, Flag), - Sm (Present_Expr, Uint))); + Sm (Present_Expr, Valid_Uint))); Cc (N_Variant_Part, Node_Kind, (Sy (Name, Node_Id, Default_Empty), @@ -1675,16 +1675,29 @@ begin -- Gen_IL.Gen.Gen_Nodes Union (N_Is_Decl, Children => - (N_Declaration, + (N_Aggregate, + N_Block_Statement, + N_Declaration, N_Discriminant_Specification, + N_Entry_Index_Specification, N_Enumeration_Type_Definition, N_Exception_Handler, + N_Explicit_Dereference, + N_Expression_With_Actions, + N_Extension_Aggregate, + N_Identifier, + N_Iterated_Component_Association, N_Later_Decl_Item, + N_Loop_Statement, + N_Null_Statement, + N_Number_Declaration, N_Package_Specification, N_Parameter_Specification, N_Renaming_Declaration, - N_Subprogram_Specification)); - -- Nodes that can be returned by Declaration_Node + N_Quantified_Expression)); + -- Nodes that can be returned by Declaration_Node; it can also return + -- Empty. Not all of these are true "declarations", but Declaration_Node + -- can return them in some cases. Union (N_Is_Range, Children => diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index e786251..f058c5a 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1197,6 +1197,12 @@ package body Gen_IL.Gen is for F in First .. Last loop if Field_Table (F).Field_Type in Node_Or_Entity_Type then Result (Node_Id) := True; + + -- Subtypes of Uint all use the same Cast for Uint + + elsif Field_Table (F).Field_Type in Uint_Subtype then + Result (Uint) := True; + else Result (Field_Table (F).Field_Type) := True; end if; @@ -1767,6 +1773,7 @@ package body Gen_IL.Gen is end if; Put_Get_Set_Incr (S, F, "Set"); + Decrease_Indent (S, 3); Put (S, "end Set_" & Image (F) & ";" & LF & LF); end Put_Setter_Body; @@ -2150,7 +2157,8 @@ package body Gen_IL.Gen is Put (S, F_Image (F) & " => (" & Image (Field_Table (F).Field_Type) & "_Field, " & - Image (Offset) & ")"); + Image (Offset) & ", " & + Image (Field_Table (F).Type_Only) & ")"); FS := Field_Size (F); FB := First_Bit (F, Offset); @@ -2245,10 +2253,32 @@ package body Gen_IL.Gen is Decrease_Indent (S, 2); Put (S, ");" & LF & LF); + Put (S, "type Type_Only_Enum is" & LF); + Increase_Indent (S, 2); + Put (S, "("); + + declare + First_Time : Boolean := True; + begin + for TO in Type_Only_Enum loop + if First_Time then + First_Time := False; + else + Put (S, ", "); + end if; + + Put (S, Image (TO)); + end loop; + end; + + Decrease_Indent (S, 2); + Put (S, ");" & LF & LF); + Put (S, "type Field_Descriptor is record" & LF); Increase_Indent (S, 3); Put (S, "Kind : Field_Kind;" & LF); Put (S, "Offset : Field_Offset;" & LF); + Put (S, "Type_Only : Type_Only_Enum;" & LF); Decrease_Indent (S, 3); Put (S, "end record;" & LF & LF); diff --git a/gcc/ada/gen_il-gen.ads b/gcc/ada/gen_il-gen.ads index 1d24ebf..56b0606 100644 --- a/gcc/ada/gen_il-gen.ads +++ b/gcc/ada/gen_il-gen.ads @@ -204,9 +204,22 @@ package Gen_IL.Gen is -- Gen_IL.Fields, and delete all occurrences from Gen_IL.Gen.Gen_Entities. -- If a field is not set, it is initialized by default to whatever value is - -- represented by all-zero bits, with two exceptions: Elist fields default - -- to No_Elist, and Uint fields default to Uint_0. In retrospect, it would - -- have been better to use No_Uint instead of Uint_0. + -- represented by all-zero bits, with some exceptions. This means Flags are + -- initialized to False, Node_Ids and List_Ids are initialized to Empty, + -- and enumeration fields are initialized to 'First of the type (assuming + -- there is no representation clause). + -- + -- Elists default to No_Elist. + -- + -- Fields of type Uint (but not its subtypes) are initialized to No_Uint. + -- Fields of subtypes Valid_Uint, Unat, Upos, Nonzero_Uint, and Ureal have + -- no default; it is an error to call a getter before calling the setter. + -- Likewise, other types whose range does not include zero have no default + -- (see package Types for the ranges). + -- + -- If a node is created by a function in Nmake, then the defaults are + -- different from what is specified above. The parameters of Make_... + -- functions can have defaults specified; see Create_Syntactic_Field. procedure Create_Node_Union_Type (T : Abstract_Node; Children : Type_Array); diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index fe1af78..a1a8062 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -370,7 +370,7 @@ package body Gen_IL.Internals is return Image (Default); else - -- Strip off the prefix and capitalize it + -- Strip off the prefix declare Im : constant String := Image (Default); diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads index a811e0b4..3febf7f 100644 --- a/gcc/ada/gen_il-internals.ads +++ b/gcc/ada/gen_il-internals.ads @@ -133,7 +133,7 @@ package Gen_IL.Internals is Default_Uint_0); -- Uint -- Default value for a field in the Nmake functions. No_Default if the -- field parameter has no default value. Otherwise this indicates the - -- default value used, which must matcht the type of the field. + -- default value used, which must match the type of the field. function Image (Default : Field_Default_Value) return String; -- This will be something like "Default_Empty". @@ -147,6 +147,9 @@ package Gen_IL.Internals is -- The default is No_Type_Only, indicating the field is not one of -- these special "[... only]" ones. + function Image (Type_Only : Type_Only_Enum) return String is + (Capitalize (Type_Only'Img)); + Unknown_Offset : constant := -1; -- Initial value of Offset, so we can tell whether it has been set @@ -191,7 +194,10 @@ package Gen_IL.Internals is function Special_Default (Field_Type : Type_Enum) return String is - (if Field_Type = Elist_Id then "No_Elist" else "Uint_0"); + (case Field_Type is + when Elist_Id => "No_Elist", + when Uint => "No_Uint", + when others => "can't happen"); ---------------- diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index 97b9dd2..9395e00 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -589,5 +589,7 @@ package Gen_IL.Types is subtype Uint_Subtype is Type_Enum with Predicate => Uint_Subtype in Valid_Uint | Unat | Upos | Nonzero_Uint; + -- These are the subtypes of Uint that have predicates restricting their + -- values. end Gen_IL.Types; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 0a962ee..129da89 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Sep 28, 2021 +GNAT Reference Manual , Oct 25, 2021 AdaCore @@ -3707,9 +3707,32 @@ overlaps the corresponding set of a later alternative, then the first set shall be a proper subset of the second (and the later alternative will not be executed if the earlier alternative “matches”). All possible values of the composite type shall be covered. The composite type of the -selector shall be a nonlimited untagged (but possibly discriminated) -record type, all of whose subcomponent subtypes are either static discrete -subtypes or record types that meet the same restrictions. +selector shall be an array or record type that is neither limited +class-wide. + +If a subcomponent’s subtype does not meet certain restrictions, then +the only value that can be specified for that subcomponent in a case +choice expression is a “box” component association (which matches all +possible values for the subcomponent). This restriction applies if + + +@itemize - + +@item +the component subtype is not a record, array, or discrete type; or + +@item +the component subtype is subject to a non-static constraint or +has a predicate; or + +@item +the component type is an enumeration type that is subject to an +enumeration representation clause; or + +@item +the component type is a multidimensional array type or an +array type with a nonstatic index subtype. +@end itemize Support for casing on arrays (and on records that contain arrays) is currently subject to some restrictions. Non-positional diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 28f2f19..cae1fad 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Sep 28, 2021 +GNAT User's Guide for Native Platforms , Oct 19, 2021 AdaCore @@ -11800,6 +11800,34 @@ This switch suppresses warnings on cases of suspicious parameter ordering. @end table +@geindex -gnatw_p (gcc) + + +@table @asis + +@item @code{-gnatw_p} + +@emph{Activate warnings for pedantic checks.} + +This switch activates warnings for the failure of certain pedantic checks. +The only case currently supported is a check that the subtype_marks given +for corresponding formal parameter and function results in a subprogram +declaration and its body denote the same subtype declaration. The default +is that such warnings are not given. +@end table + +@geindex -gnatw_P (gcc) + + +@table @asis + +@item @code{-gnatw_P} + +@emph{Suppress warnings for pedantic checks.} + +This switch suppresses warnings on violations of pedantic checks. +@end table + @geindex -gnatwq (gcc) @geindex Parentheses diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index c676996..68990e1 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -234,9 +234,8 @@ procedure Gnatls is -- already been initialized. procedure Add_Directories - (Self : in out String_Access; - Path : String; - Prepend : Boolean := False); + (Self : in out String_Access; + Path : String); -- Add one or more directories to the path. Directories added with this -- procedure are added in order after the current directory and before -- the path given by the environment variable GPR_PROJECT_PATH. A value @@ -1239,9 +1238,8 @@ procedure Gnatls is --------------------- procedure Add_Directories - (Self : in out String_Access; - Path : String; - Prepend : Boolean := False) + (Self : in out String_Access; + Path : String) is Tmp : String_Access; @@ -1250,11 +1248,7 @@ procedure Gnatls is Self := new String'(Uninitialized_Prefix & Path); else Tmp := Self; - if Prepend then - Self := new String'(Path & Path_Separator & Tmp.all); - else - Self := new String'(Tmp.all & Path_Separator & Path); - end if; + Self := new String'(Tmp.all & Path_Separator & Path); Free (Tmp); end if; end Add_Directories; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 773b376..08c454d 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -327,8 +327,8 @@ package body Inline is -- Unreferenced procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id); - -- Reset the Renamed_Object flags on the formals of Subp, which can be set - -- by a call to Establish_Actual_Mapping_For_Inlined_Call. + -- Reset the Renamed_Object field to Empty on all formals of Subp, which + -- can be set by a call to Establish_Actual_Mapping_For_Inlined_Call. ------------------------------ -- Deferred Cleanup Actions -- @@ -2894,7 +2894,7 @@ package body Inline is if Present (Renamed_Object (F)) then -- If expander is active, it is an error to try to inline a - -- recursive program. In GNATprove mode, just indicate that the + -- recursive subprogram. In GNATprove mode, just indicate that the -- inlining will not happen, and mark the subprogram as not always -- inlined. diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 17de886..2c3c372 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -481,7 +481,9 @@ package body Lib.Xref is -- e.g. function call, slicing of a function call, -- pointer dereference, etc. - if No (Obj) then + if No (Obj) + or else Ekind (Obj) = E_Enumeration_Literal + then return Empty; end if; else diff --git a/gcc/ada/libgnarl/a-intnam__rtems.ads b/gcc/ada/libgnarl/a-intnam__rtems.ads index 89618f6..4654f00 100644 --- a/gcc/ada/libgnarl/a-intnam__rtems.ads +++ b/gcc/ada/libgnarl/a-intnam__rtems.ads @@ -34,81 +34,17 @@ ------------------------------------------------------------------------------ -- This is a RTEMS version of this package --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGEMT, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handlers - --- This target-dependent package spec contains names of interrupts --- supported by the local system. with System.OS_Interface; --- used for names of interrupts package Ada.Interrupts.Names is - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill + -- All identifiers in this unit are implementation defined - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 + pragma Implementation_Defined; - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 + subtype Hardware_Interrupts is Interrupt_ID + range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; + -- Range of values that can be used for hardware interrupts end Ada.Interrupts.Names; diff --git a/gcc/ada/libgnarl/s-inmaop__vxworks.adb b/gcc/ada/libgnarl/s-inmaop__hwint.adb index 8496c82..52a92ac 100644 --- a/gcc/ada/libgnarl/s-inmaop__vxworks.adb +++ b/gcc/ada/libgnarl/s-inmaop__hwint.adb @@ -30,9 +30,10 @@ -- -- ------------------------------------------------------------------------------ --- This is a VxWorks version of this package. Many operations are null as this --- package supports the use of Ada interrupt handling facilities for signals, --- while those facilities are used for hardware interrupts on these targets. +-- This is a hardware interrupt version of this package. Many operations are +-- null as this package supports the use of Ada interrupt handling facilities +-- for signals, while those facilities are used for hardware interrupts on +-- these targets. with Ada.Exceptions; diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb index be6b559..5f80174 100644 --- a/gcc/ada/libgnarl/s-interr__hwint.adb +++ b/gcc/ada/libgnarl/s-interr__hwint.adb @@ -29,29 +29,15 @@ -- -- ------------------------------------------------------------------------------ --- Invariants: - --- All user-handlable signals are masked at all times in all tasks/threads --- except possibly for the Interrupt_Manager task. - --- When a user task wants to have the effect of masking/unmasking an signal, --- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect --- of unmasking/masking the signal in the Interrupt_Manager task. These --- comments do not apply to vectored hardware interrupts, which may be masked --- or unmasked using routined interfaced to the relevant embedded RTOS system --- calls. +-- This is reasonably generic version of this package, supporting vectored +-- hardware interrupts using non-RTOS specific adapter routines which should +-- easily implemented on any RTOS capable of supporting GNAT. --- Once we associate a Signal_Server_Task with an signal, the task never goes --- away, and we never remove the association. On the other hand, it is more --- convenient to terminate an associated Interrupt_Server_Task for a vectored --- hardware interrupt (since we use a binary semaphore for synchronization --- with the umbrella handler). +-- Invariants: --- There is no more than one signal per Signal_Server_Task and no more than --- one Signal_Server_Task per signal. The same relation holds for hardware --- interrupts and Interrupt_Server_Task's at any given time. That is, only --- one non-terminated Interrupt_Server_Task exists for a give interrupt at --- any time. +-- There is no more than one interrupt per Interrupt_Server_Task and no more +-- than one Interrupt_Server_Task per interrupt. If an interrupt handler is +-- detached, the corresponding Interrupt_Server_Task is terminated. -- Within this package, the lock L is used to protect the various status -- tables. If there is a Server_Task associated with a signal or interrupt, @@ -59,10 +45,6 @@ -- status between Interrupt_Manager and Server_Task. Protection among service -- requests are ensured via user calls to the Interrupt_Manager entries. --- This is reasonably generic version of this package, supporting vectored --- hardware interrupts using non-RTOS specific adapter routines which should --- easily implemented on any RTOS capable of supporting GNAT. - with Ada.Unchecked_Conversion; with Ada.Task_Identification; @@ -151,13 +133,13 @@ package body System.Interrupts is (others => (null, Static => False)); pragma Volatile_Components (User_Handler); -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt or signal. A handler is static iff it + -- information for each interrupt. A handler is static if and only if it -- is specified through the pragma Attach_Handler. User_Entry : array (Interrupt_ID) of Entry_Assoc := (others => (T => Null_Task, E => Null_Task_Entry)); pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt / signal + -- Holds the task and entry index (if any) for each interrupt -- Type and Head, Tail of the list containing Registered Interrupt -- Handlers. These definitions are used to register the handlers diff --git a/gcc/ada/libgnarl/s-intman__android.adb b/gcc/ada/libgnarl/s-intman__android.adb index 6364ead..be9c50e 100644 --- a/gcc/ada/libgnarl/s-intman__android.adb +++ b/gcc/ada/libgnarl/s-intman__android.adb @@ -68,7 +68,7 @@ package body System.Interrupt_Management is Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-intman__lynxos.adb b/gcc/ada/libgnarl/s-intman__lynxos.adb index c2e8f8a..2a1f9c8 100644 --- a/gcc/ada/libgnarl/s-intman__lynxos.adb +++ b/gcc/ada/libgnarl/s-intman__lynxos.adb @@ -68,7 +68,7 @@ package body System.Interrupt_Management is Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-intman__posix.adb b/gcc/ada/libgnarl/s-intman__posix.adb index b0b0146..ae3d77e 100644 --- a/gcc/ada/libgnarl/s-intman__posix.adb +++ b/gcc/ada/libgnarl/s-intman__posix.adb @@ -68,7 +68,7 @@ package body System.Interrupt_Management is Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-intman__qnx.adb b/gcc/ada/libgnarl/s-intman__qnx.adb index e983a9e..8934bdf 100644 --- a/gcc/ada/libgnarl/s-intman__qnx.adb +++ b/gcc/ada/libgnarl/s-intman__qnx.adb @@ -68,7 +68,7 @@ package body System.Interrupt_Management is Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-intman__rtems.adb b/gcc/ada/libgnarl/s-intman__rtems.adb new file mode 100644 index 0000000..dedc67c --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__rtems.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package + +-- It is simpler than other versions because the Ada interrupt handling +-- mechanisms are used for hardware interrupts rather than signals. + +package body System.Interrupt_Management is + + use System.OS_Interface; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- hardware interrupt number, and the result is one of the following: + + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + -- Set to True once Initialize is called, further calls have no effect + + procedure Initialize is + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Set the signal used to signal an abort to another task as defined in + -- System.OS_Interface. + + Abort_Task_Interrupt := SIGADAABORT; + + -- Initialize hardware interrupt handling + + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Check all interrupts for state that requires keeping them reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Reserve (J) := True; + end if; + end loop; + + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/libgnarl/s-intman__rtems.ads b/gcc/ada/libgnarl/s-intman__rtems.ads new file mode 100644 index 0000000..f3d53ec --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__rtems.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package + +-- This package encapsulates and centralizes information about all +-- uses of interrupts (or signals), including the target-dependent +-- mapping of interrupts (or signals) to exceptions. + +-- Unlike the original design, System.Interrupt_Management can only +-- be used for tasking systems. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. The type +-- Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according +-- to the Ada Reference Manual. This is the reason why the signals +-- sets are implemented using visible arrays rather than functions. + +with System.OS_Interface; + +with Interfaces.C; + +package System.Interrupt_Management is + pragma Preelaborate; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1; + + type Signal_Set is array (Signal_ID) of Boolean; + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. + + -- For example, suppose SIGRARE is a signal that is not defined on all + -- systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write: + -- Reserved (SIGRARE) := True; + -- and the initialization code will be portable. + + Abort_Task_Interrupt : Signal_ID; + -- The signal that is used to implement task abort if an interrupt is used + -- for that purpose. This is one of the reserved signals. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. + + procedure Initialize; + -- Initialize the various variables defined in this package. This procedure + -- must be called before accessing any object from this package and can be + -- called multiple times (only the first call has any effect). + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementation Interrupt_Mask can be represented as a linked + -- list. + +end System.Interrupt_Management; diff --git a/gcc/ada/libgnarl/s-intman__solaris.adb b/gcc/ada/libgnarl/s-intman__solaris.adb index 3871457..76002a7 100644 --- a/gcc/ada/libgnarl/s-intman__solaris.adb +++ b/gcc/ada/libgnarl/s-intman__solaris.adb @@ -47,7 +47,7 @@ package body System.Interrupt_Management is Exception_Interrupts : constant Interrupt_List := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-intman__susv3.adb b/gcc/ada/libgnarl/s-intman__susv3.adb index b33d76d..f2870cb 100644 --- a/gcc/ada/libgnarl/s-intman__susv3.adb +++ b/gcc/ada/libgnarl/s-intman__susv3.adb @@ -56,7 +56,7 @@ package body System.Interrupt_Management is use Interfaces.C; use System.OS_Interface; - Unreserve_All_Interrupts : Interfaces.C.int; + Unreserve_All_Interrupts : constant Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb index cd977d0..96883af 100644 --- a/gcc/ada/libgnarl/s-osinte__rtems.adb +++ b/gcc/ada/libgnarl/s-osinte__rtems.adb @@ -44,6 +44,54 @@ with Interfaces.C; use Interfaces.C; package body System.OS_Interface is + --------------- + -- RTEMS API -- + --------------- + + type RTEMS_Attributes is new unsigned; + + RTEMS_SIMPLE_BINARY_SEMAPHORE : constant := 16#00000020#; + RTEMS_FIFO : constant := 16#00000000#; + + type RTEMS_Interval is new unsigned; + + RTEMS_NO_TIMEOUT : constant := 0; + + type RTEMS_Options is new unsigned; + + RTEMS_WAIT : constant := 16#00000000#; + RTEMS_INTERRUPT_UNIQUE : constant := 16#00000001#; + + type RTEMS_Name is new unsigned; + + function RTEMS_Build_Name (C1, C2, C3, C4 : Character) return RTEMS_Name + with Import, External_Name => "rtems_build_name", Convention => C; + + function RTEMS_Semaphore_Create + (Name : RTEMS_Name; + Count : unsigned; + Attributes : RTEMS_Attributes; + Priority_Ceiling : unsigned; + Semaphore : out Binary_Semaphore_Id) return int + with Import, External_Name => "rtems_semaphore_create", Convention => C; + + function RTEMS_Semaphore_Delete (Semaphore : Binary_Semaphore_Id) return int + with Import, External_Name => "rtems_semaphore_delete", Convention => C; + + function RTEMS_Semaphore_Flush (Semaphore : Binary_Semaphore_Id) + return int + with Import, External_Name => "rtems_semaphore_flush", Convention => C; + + function RTEMS_Semaphore_Obtain + (Semaphore : Binary_Semaphore_Id; + Options : RTEMS_Options; + Timeout : RTEMS_Interval) return int + with Import, External_Name => "rtems_semaphore_obtain", Convention => C; + + function RTEMS_Semaphore_Release (Semaphore : Binary_Semaphore_Id) + return int + with Import, External_Name => "rtems_semaphore_release", Convention => C; + ----------------- -- To_Duration -- ----------------- @@ -85,6 +133,108 @@ package body System.OS_Interface is tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; + ----------------------------- + -- Binary_Semaphore_Create -- + ----------------------------- + + function Binary_Semaphore_Create return Binary_Semaphore_Id is + Semaphore : Binary_Semaphore_Id; + Status : int; + begin + Status := + RTEMS_Semaphore_Create + (Name => RTEMS_Build_Name ('G', 'N', 'A', 'T'), + Count => 0, + Attributes => RTEMS_SIMPLE_BINARY_SEMAPHORE or RTEMS_FIFO, + Priority_Ceiling => 0, + Semaphore => Semaphore); + + pragma Assert (Status = 0); + + return Semaphore; + end Binary_Semaphore_Create; + + ----------------------------- + -- Binary_Semaphore_Delete -- + ----------------------------- + + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) + return int is + begin + return RTEMS_Semaphore_Delete (ID); + end Binary_Semaphore_Delete; + + ----------------------------- + -- Binary_Semaphore_Obtain -- + ----------------------------- + + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) + return int is + begin + return RTEMS_Semaphore_Obtain (ID, RTEMS_WAIT, RTEMS_NO_TIMEOUT); + end Binary_Semaphore_Obtain; + + ------------------------------ + -- Binary_Semaphore_Release -- + ------------------------------ + + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) + return int is + begin + return RTEMS_Semaphore_Release (ID); + end Binary_Semaphore_Release; + + ---------------------------- + -- Binary_Semaphore_Flush -- + ---------------------------- + + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is + begin + return RTEMS_Semaphore_Flush (ID); + end Binary_Semaphore_Flush; + + ----------------------- + -- Interrupt_Connect -- + ----------------------- + + function Interrupt_Connect + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int + is + function RTEMS_Interrupt_Handler_Install + (Vector : Interrupt_Vector; + Info : char_array; + Options : RTEMS_Options; + Handler : Interrupt_Handler; + Parameter : System.Address) return int + with Import, + External_Name => "rtems_interrupt_handler_install", + Convention => C; + + Info_String : constant char_array := To_C ("GNAT Interrupt Handler"); + -- Handler name that is registered with RTEMS + begin + return + RTEMS_Interrupt_Handler_Install + (Vector => Vector, + Info => Info_String, + Options => RTEMS_INTERRUPT_UNIQUE, + Handler => Handler, + Parameter => Parameter); + end Interrupt_Connect; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + + function Interrupt_Number_To_Vector (intNum : int) + return Interrupt_Vector + is + begin + return Interrupt_Vector (intNum); + end Interrupt_Number_To_Vector; + ------------------ -- pthread_init -- ------------------ diff --git a/gcc/ada/libgnarl/s-osinte__rtems.ads b/gcc/ada/libgnarl/s-osinte__rtems.ads index ffbfc3a..9a0561f 100644 --- a/gcc/ada/libgnarl/s-osinte__rtems.ads +++ b/gcc/ada/libgnarl/s-osinte__rtems.ads @@ -85,18 +85,20 @@ package System.OS_Interface is ENOMEM : constant := System.OS_Constants.ENOMEM; ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT; - ------------- - -- Signals -- - ------------- + ---------------------------- + -- Signals and Interrupts -- + ---------------------------- - Num_HW_Interrupts : constant := 256; + NSIG : constant := 64; + -- Number of signals on the target OS + type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); - Max_HW_Interrupt : constant := Num_HW_Interrupts - 1; + Max_HW_Interrupt : constant := 255; type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; Max_Interrupt : constant := Max_HW_Interrupt; - - type Signal is new int range 0 .. Max_Interrupt; + subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt; + -- For s-interr SIGXCPU : constant := 0; -- XCPU SIGHUP : constant := 1; -- hangup @@ -546,34 +548,19 @@ package System.OS_Interface is type Binary_Semaphore_Id is new rtems_id; function Binary_Semaphore_Create return Binary_Semaphore_Id; - pragma Import ( - C, - Binary_Semaphore_Create, - "__gnat_binary_semaphore_create"); + pragma Inline (Binary_Semaphore_Create); function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; - pragma Import ( - C, - Binary_Semaphore_Delete, - "__gnat_binary_semaphore_delete"); + pragma Inline (Binary_Semaphore_Delete); function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; - pragma Import ( - C, - Binary_Semaphore_Obtain, - "__gnat_binary_semaphore_obtain"); + pragma Inline (Binary_Semaphore_Obtain); function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; - pragma Import ( - C, - Binary_Semaphore_Release, - "__gnat_binary_semaphore_release"); + pragma Inline (Binary_Semaphore_Release); function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; - pragma Import ( - C, - Binary_Semaphore_Flush, - "__gnat_binary_semaphore_flush"); + pragma Inline (Binary_Semaphore_Flush); ------------------------------------------------------------ -- Hardware Interrupt Wrappers to Support Interrupt Tasks -- @@ -581,40 +568,24 @@ package System.OS_Interface is type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); + type Interrupt_Vector is new System.Address; function Interrupt_Connect - (vector : Interrupt_Vector; - handler : Interrupt_Handler; - parameter : System.Address := System.Null_Address) return int; - pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect"); + (Vector : Interrupt_Vector; + Handler : Interrupt_Handler; + Parameter : System.Address := System.Null_Address) return int; -- Use this to set up an user handler. The routine installs a -- a user handler which is invoked after RTEMS has saved enough -- context for a high-level language routine to be safely invoked. - function Interrupt_Vector_Get - (Vector : Interrupt_Vector) return Interrupt_Handler; - pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get"); - -- Use this to get the existing handler for later restoral. - - procedure Interrupt_Vector_Set - (Vector : Interrupt_Vector; - Handler : Interrupt_Handler); - pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set"); - -- Use this to restore a handler obtained using Interrupt_Vector_Get. - function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; -- Convert a logical interrupt number to the hardware interrupt vector -- number used to connect the interrupt. - pragma Import ( - C, - Interrupt_Number_To_Vector, - "__gnat_interrupt_number_to_vector" - ); private - type sigset_t is new int; + type sigset_t is new unsigned_long; type pid_t is new int; diff --git a/gcc/ada/libgnarl/s-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb index 754d175..1f304d9 100644 --- a/gcc/ada/libgnarl/s-taprob.adb +++ b/gcc/ada/libgnarl/s-taprob.adb @@ -47,7 +47,7 @@ package body System.Tasking.Protected_Objects is -- Local Data -- ---------------- - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); ------------------------- diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb index ebd8941..9bded3a 100644 --- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb @@ -87,10 +87,10 @@ package body System.Task_Primitives.Operations is Unblocked_Signal_Mask : aliased sigset_t; -- The set of signals that should unblocked in all tasks - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); -- Note: the reason that Locking_Policy is not needed is that this diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index 93ffb3a..1c8c6bd 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -84,13 +84,13 @@ package body System.Task_Primitives.Operations is Next_Serial_Number : Task_Serial_Number := 100; -- We start at 100 (reserve some special values for using in error checks) - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); Foreign_Task_Elaborated : aliased Boolean := True; diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb index 4d9b163..33d5977 100644 --- a/gcc/ada/libgnarl/s-taprop__mingw.adb +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -109,10 +109,10 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used to protect All_Tasks_List - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); function Get_Policy (Prio : System.Any_Priority) return Character; diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index 3dc12c8..c0766a0 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -83,7 +83,7 @@ package body System.Task_Primitives.Operations is Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); -- Value of the pragma Locking_Policy: -- 'C' for Ceiling_Locking @@ -99,10 +99,10 @@ package body System.Task_Primitives.Operations is -- We start at 100, to reserve some special values for -- using in error checking. - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index 9446e37..e7faf08 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -83,7 +83,7 @@ package body System.Task_Primitives.Operations is Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); -- Value of the pragma Locking_Policy: -- 'C' for Ceiling_Locking @@ -99,10 +99,10 @@ package body System.Task_Primitives.Operations is -- We start at 100, to reserve some special values for -- using in error checking. - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb new file mode 100644 index 0000000..9153032 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__rtems.adb @@ -0,0 +1,1347 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Constants; +with System.OS_Primitives; +with System.Task_Info; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package OSC renames System.OS_Constants; + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used to protect All_Tasks_List + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Locking_Policy : constant Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : constant Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : constant Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + package Monotonic is + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns an absolute time, represented as an offset relative to some + -- unspecified starting point, typically system boot time. This clock + -- is not affected by discontinuous jumps in the system time. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns resolution of the underlying clock used to implement RT_Clock + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implement the semantics of the delay statement. + -- The caller should be abort-deferred and should not hold any locks. + + end Monotonic; + + package body Monotonic is separate; + + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. + + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + -- See also comment before body, below. + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + function GNAT_pthread_condattr_setup + (attr : access pthread_condattr_t) return int; + pragma Import (C, + GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + + ------------------- + -- Abort_Handler -- + ------------------- + + -- Target-dependent binding of inter-thread Abort signal to the raising of + -- the Abort_Signal exception. + + -- The technical issues and alternatives here are essentially the + -- same as for raising exceptions in response to other signals + -- (e.g. Storage_Error). See code and comments in the package body + -- System.Interrupt_Management. + + -- Some implementations may not allow an exception to be propagated out of + -- a handler, and others might leave the signal or interrupt that invoked + -- this handler masked after the exceptional return to the application + -- code. + + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On + -- most UNIX systems, this will allow transfer out of a signal handler, + -- which is usually the only mechanism available for implementing + -- asynchronous handlers of this kind. However, some systems do not + -- restore the signal mask on longjmp(), leaving the abort signal masked. + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Old_Set : aliased sigset_t; + Unblocked_Mask : aliased sigset_t; + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := sigemptyset (Unblocked_Mask'Access); + pragma Assert (Result = 0); + Result := + sigaddset + (Unblocked_Mask'Access, + Signal (Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGBUS); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGFPE); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGILL); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGSEGV); + pragma Assert (Result = 0); + + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Mask'Access, + Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Page_Size : Address; + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Page_Size := Address (Get_Page_Size); + Res := + mprotect + (Stack_Base - (Stack_Base mod Page_Size) + Page_Size, + size_t (Page_Size), + prot => (if On then PROT_ON else PROT_OFF)); + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L.WO'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.WO'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_lock (L.WO'Access); + + -- The cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); + end Write_Lock; + + procedure Write_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.WO'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => Self_ID.Common.LL.L'Access); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) renames Monotonic.Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration renames Monotonic.RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := To_Target_Priority (Prio); + + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + if Use_Alternate_Stack then + declare + Stack : aliased stack_t; + Result : Interfaces.C.int; + begin + Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; + Stack.ss_size := Alternate_Stack_Size; + Stack.ss_flags := 0; + Result := sigaltstack (Stack'Access, null); + pragma Assert (Result = 0); + end; + end if; + end Enter_Task; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + if Locking_Policy = 'C' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Page_Size : constant Interfaces.C.size_t := + Interfaces.C.size_t (Get_Page_Size); + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size; + end if; + + -- Round stack size as this is required by some OSes (Darwin) + + Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1; + Adjusted_Stack_Size := + Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + case T.Common.Task_Info is + when System.Task_Info.Process_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); + + when System.Task_Info.System_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + + when System.Task_Info.Default_Scope => + Result := 0; + end case; + + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + + Result := pthread_create + (T.Common.LL.Thread'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + ATCB_Allocation.Free_ATCB (T); + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + -- Mark this task as unknown, so that if Self is called, it won't + -- return a dangling pointer. + + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10 (6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Storage_Error is propagated as intended if the allocation of the + -- underlying OS entities fails. + + raise Storage_Error; + + else + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + + -- Storage_Error is propagated as intended if the allocation of the + -- underlying OS entities fails. + + raise Storage_Error; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in (RM D.10(9)). Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T, Thread_Self); + begin + return False; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- 'n' this interrupt not set by any Interrupt_State pragma + -- 'u' Interrupt_State pragma set state to User + -- 'r' Interrupt_State pragma set state to Runtime + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb index 4c449b6..faaaeea 100644 --- a/gcc/ada/libgnarl/s-taprop__solaris.adb +++ b/gcc/ada/libgnarl/s-taprop__solaris.adb @@ -128,13 +128,13 @@ package body System.Task_Primitives.Operations is -- External Configuration Values -- ----------------------------------- - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb index 273aca8..ff21410 100644 --- a/gcc/ada/libgnarl/s-taprop__vxworks.adb +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -88,13 +88,13 @@ package body System.Task_Primitives.Operations is -- The followings are internal configuration constants needed - Dispatching_Policy : Character; + Dispatching_Policy : constant Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); Mutex_Protocol : Priority_Type; @@ -104,7 +104,7 @@ package body System.Task_Primitives.Operations is -- time; it is used to execute in mutual exclusion from all other tasks. -- Used to protect All_Tasks_List - Time_Slice_Val : Integer; + Time_Slice_Val : constant Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); Null_Thread_Id : constant Thread_Id := 0; diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb index 0090964..ab50af1 100644 --- a/gcc/ada/libgnarl/s-taskin.adb +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -173,13 +173,13 @@ package body System.Tasking is Main_Task_Image : constant String := "main_task"; -- Image of environment task - Main_Priority : Integer; + Main_Priority : constant Integer; pragma Import (C, Main_Priority, "__gl_main_priority"); -- Priority for main task. Note that this is of type Integer, not Priority, -- because we use the value -1 to indicate the default main priority, and -- that is of course not in Priority'range. - Main_CPU : Integer; + Main_CPU : constant Integer; pragma Import (C, Main_CPU, "__gl_main_cpu"); -- Affinity for main task. Note that this is of type Integer, not -- CPU_Range, because we use the value -1 to indicate the unassigned diff --git a/gcc/ada/libgnarl/s-tasque.adb b/gcc/ada/libgnarl/s-tasque.adb index 28f033a..79382c4 100644 --- a/gcc/ada/libgnarl/s-tasque.adb +++ b/gcc/ada/libgnarl/s-tasque.adb @@ -44,7 +44,7 @@ package body System.Tasking.Queuing is -- Entry Queues implemented as doubly linked list - Queuing_Policy : Character; + Queuing_Policy : constant Character; pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; diff --git a/gcc/ada/libgnarl/s-tpoben.adb b/gcc/ada/libgnarl/s-tpoben.adb index 896ee0c..0cb3677 100644 --- a/gcc/ada/libgnarl/s-tpoben.adb +++ b/gcc/ada/libgnarl/s-tpoben.adb @@ -58,7 +58,7 @@ package body System.Tasking.Protected_Objects.Entries is -- Local Data -- ---------------- - Locking_Policy : Character; + Locking_Policy : constant Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); -------------- diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb index 5dedfc5..b24e95d 100644 --- a/gcc/ada/libgnat/a-calend.adb +++ b/gcc/ada/libgnat/a-calend.adb @@ -149,7 +149,7 @@ is -- Leap seconds control -- -------------------------- - Flag : Integer; + Flag : constant Integer; pragma Import (C, Flag, "__gl_leap_seconds_support"); -- This imported value is used to determine whether the compilation had -- binder flag "-y" present which enables leap seconds. A value of zero diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb index 3939287..a8e6a58 100644 --- a/gcc/ada/libgnat/a-excach.adb +++ b/gcc/ada/libgnat/a-excach.adb @@ -41,7 +41,7 @@ pragma Warnings (On); separate (Ada.Exceptions) procedure Call_Chain (Excep : EOA) is - Exception_Tracebacks : Integer; + Exception_Tracebacks : constant Integer; pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); -- Boolean indicating whether tracebacks should be stored in exception -- occurrences. diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index 5933928..631c35a 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -1760,7 +1760,7 @@ package body Ada.Exceptions is -- Wide_Exception_Name -- ------------------------- - WC_Encoding : Character; + WC_Encoding : constant Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); -- Encoding method for source, as exported by binder diff --git a/gcc/ada/libgnat/g-io-put__vxworks.adb b/gcc/ada/libgnat/a-nbnbin__ghost.adb index 29307f9..7d22086 100644 --- a/gcc/ada/libgnat/g-io-put__vxworks.adb +++ b/gcc/ada/libgnat/a-nbnbin__ghost.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T . I O -- +-- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS -- -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2021, AdaCore -- +-- Copyright (C) 2021, 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- -- @@ -29,25 +29,48 @@ -- -- ------------------------------------------------------------------------------ --- vxworks zfp version of Put (C : Character) +-- This body is provided as a work-around for a GNAT compiler bug, as GNAT +-- currently does not compile instantiations of the spec with imported ghost +-- generics for packages Signed_Conversions and Unsigned_Conversions. -with Interfaces.C; use Interfaces.C; +package body Ada.Numerics.Big_Numbers.Big_Integers with + SPARK_Mode => Off +is -separate (GNAT.IO) -procedure Put (C : Character) is + package body Signed_Conversions with + SPARK_Mode => Off + is - function ioGlobalStdGet - (File : int) return int; - pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet"); + function To_Big_Integer (Arg : Int) return Valid_Big_Integer is + begin + raise Program_Error; + return (null record); + end To_Big_Integer; - procedure fdprintf - (File : int; - Format : String; - Value : Character); - pragma Import (C, fdprintf, "fdprintf"); + function From_Big_Integer (Arg : Valid_Big_Integer) return Int is + begin + raise Program_Error; + return 0; + end From_Big_Integer; - Stdout_ID : constant int := 1; + end Signed_Conversions; -begin - fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C); -end Put; + package body Unsigned_Conversions with + SPARK_Mode => Off + is + + function To_Big_Integer (Arg : Int) return Valid_Big_Integer is + begin + raise Program_Error; + return (null record); + end To_Big_Integer; + + function From_Big_Integer (Arg : Valid_Big_Integer) return Int is + begin + raise Program_Error; + return 0; + end From_Big_Integer; + + end Unsigned_Conversions; + +end Ada.Numerics.Big_Numbers.Big_Integers; diff --git a/gcc/ada/libgnat/a-nbnbin__ghost.ads b/gcc/ada/libgnat/a-nbnbin__ghost.ads new file mode 100644 index 0000000..3663dd7 --- /dev/null +++ b/gcc/ada/libgnat/a-nbnbin__ghost.ads @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Numerics.Big_Numbers.Big_Integers with + SPARK_Mode, + Ghost, + Preelaborate +is + type Big_Integer is private + with Integer_Literal => From_Universal_Image; + + function Is_Valid (Arg : Big_Integer) return Boolean + with + Import, + Global => null; + + subtype Valid_Big_Integer is Big_Integer + with Dynamic_Predicate => Is_Valid (Valid_Big_Integer), + Predicate_Failure => raise Program_Error; + + function "=" (L, R : Valid_Big_Integer) return Boolean with + Import, + Global => null; + + function "<" (L, R : Valid_Big_Integer) return Boolean with + Import, + Global => null; + + function "<=" (L, R : Valid_Big_Integer) return Boolean with + Import, + Global => null; + + function ">" (L, R : Valid_Big_Integer) return Boolean with + Import, + Global => null; + + function ">=" (L, R : Valid_Big_Integer) return Boolean with + Import, + Global => null; + + function To_Big_Integer (Arg : Integer) return Valid_Big_Integer + with + Import, + Global => null; + + subtype Big_Positive is Big_Integer + with Dynamic_Predicate => + (if Is_Valid (Big_Positive) + then Big_Positive > To_Big_Integer (0)), + Predicate_Failure => (raise Constraint_Error); + + subtype Big_Natural is Big_Integer + with Dynamic_Predicate => + (if Is_Valid (Big_Natural) + then Big_Natural >= To_Big_Integer (0)), + Predicate_Failure => (raise Constraint_Error); + + function In_Range + (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean + is (Low <= Arg and Arg <= High) + with + Import, + Global => null; + + function To_Integer (Arg : Valid_Big_Integer) return Integer + with + Import, + Pre => In_Range (Arg, + Low => To_Big_Integer (Integer'First), + High => To_Big_Integer (Integer'Last)) + or else (raise Constraint_Error), + Global => null; + + generic + type Int is range <>; + package Signed_Conversions is + + function To_Big_Integer (Arg : Int) return Valid_Big_Integer + with + Global => null; + + function From_Big_Integer (Arg : Valid_Big_Integer) return Int + with + Pre => In_Range (Arg, + Low => To_Big_Integer (Int'First), + High => To_Big_Integer (Int'Last)) + or else (raise Constraint_Error), + Global => null; + end Signed_Conversions; + + generic + type Int is mod <>; + package Unsigned_Conversions is + + function To_Big_Integer (Arg : Int) return Valid_Big_Integer + with + Global => null; + + function From_Big_Integer (Arg : Valid_Big_Integer) return Int + with + Pre => In_Range (Arg, + Low => To_Big_Integer (Int'First), + High => To_Big_Integer (Int'Last)) + or else (raise Constraint_Error), + Global => null; + + end Unsigned_Conversions; + + function From_String (Arg : String) return Valid_Big_Integer + with + Import, + Global => null; + + function From_Universal_Image (Arg : String) return Valid_Big_Integer + renames From_String; + + function "+" (L : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "-" (L : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer + with + Import, + Global => null; + + function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer + with + Import, + Global => null; + + function Greatest_Common_Divisor + (L, R : Valid_Big_Integer) return Big_Positive + with + Import, + Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0)) + or else (raise Constraint_Error), + Global => null; + +private + pragma SPARK_Mode (Off); + + type Big_Integer is null record; + +end Ada.Numerics.Big_Numbers.Big_Integers; diff --git a/gcc/ada/libgnat/a-nbnbin__gmp.adb b/gcc/ada/libgnat/a-nbnbin__gmp.adb index 880e9a3..1516f49 100644 --- a/gcc/ada/libgnat/a-nbnbin__gmp.adb +++ b/gcc/ada/libgnat/a-nbnbin__gmp.adb @@ -327,7 +327,7 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is -- From_String -- ----------------- - function From_String (Arg : String) return Big_Integer is + function From_String (Arg : String) return Valid_Big_Integer is function mpz_set_str (this : access mpz_t; str : System.Address; diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 7428e9c..ae4339f 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -76,7 +76,8 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length. function Super_Length (Source : Super_String) return Natural - is (Source.Current_Length); + is (Source.Current_Length) + with Global => null; -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- @@ -620,7 +621,8 @@ package Ada.Strings.Superbounded with SPARK_Mode is is (if Index <= Source.Current_Length then Source.Data (Index) else raise Index_Error) - with Pre => Index <= Super_Length (Source); + with Pre => Index <= Super_Length (Source), + Global => null; procedure Super_Replace_Element (Source : in out Super_String; @@ -649,8 +651,9 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- get the null string in accordance with normal Ada slice rules. String (Source.Data (Low .. High))) - with Pre => Low - 1 <= Super_Length (Source) - and then High <= Super_Length (Source); + with Pre => Low - 1 <= Super_Length (Source) + and then High <= Super_Length (Source), + Global => null; function Super_Slice (Source : Super_String; diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb index 4727f965..0d62e4b 100644 --- a/gcc/ada/libgnat/a-strunb.adb +++ b/gcc/ada/libgnat/a-strunb.adb @@ -505,8 +505,14 @@ package body Ada.Strings.Unbounded is -- Note: Don't try to free statically allocated null string if Object.Reference /= Null_String'Access then - Deallocate (Object.Reference); - Object.Reference := Null_Unbounded_String.Reference; + declare + Reference_Copy : String_Access := Object.Reference; + -- The original reference cannot be null, so we must create a + -- copy which will become null when deallocated. + begin + Deallocate (Reference_Copy); + Object.Reference := Null_Unbounded_String.Reference; + end; Object.Last := 0; end if; end Finalize; diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index b3050fd..2f5bd94 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -746,8 +746,8 @@ private renames To_Unbounded_String; type Unbounded_String is new AF.Controlled with record - Reference : String_Access := Null_String'Access; - Last : Natural := 0; + Reference : not null String_Access := Null_String'Access; + Last : Natural := 0; end record with Put_Image => Put_Image; procedure Put_Image diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb index c6a9d25..170d16a 100644 --- a/gcc/ada/libgnat/a-tags.adb +++ b/gcc/ada/libgnat/a-tags.adb @@ -1032,7 +1032,7 @@ package body Ada.Tags is -- Wide_Expanded_Name -- ------------------------ - WC_Encoding : Character; + WC_Encoding : constant Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); -- Encoding method for source, as exported by binder diff --git a/gcc/ada/libgnat/a-textio.adb b/gcc/ada/libgnat/a-textio.adb index 8667360..1bdab6e 100644 --- a/gcc/ada/libgnat/a-textio.adb +++ b/gcc/ada/libgnat/a-textio.adb @@ -67,7 +67,7 @@ is use type System.CRTL.size_t; - WC_Encoding : Character; + WC_Encoding : constant Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); -- Default wide character encoding diff --git a/gcc/ada/libgnat/a-witeio.adb b/gcc/ada/libgnat/a-witeio.adb index 7dbd3b3..dbc0f2a 100644 --- a/gcc/ada/libgnat/a-witeio.adb +++ b/gcc/ada/libgnat/a-witeio.adb @@ -55,7 +55,7 @@ package body Ada.Wide_Text_IO is use type System.CRTL.size_t; - WC_Encoding : Character; + WC_Encoding : constant Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); -- Default wide character encoding diff --git a/gcc/ada/libgnat/a-ztexio.adb b/gcc/ada/libgnat/a-ztexio.adb index 71d733e..b72a1d4 100644 --- a/gcc/ada/libgnat/a-ztexio.adb +++ b/gcc/ada/libgnat/a-ztexio.adb @@ -55,7 +55,7 @@ package body Ada.Wide_Wide_Text_IO is use type System.CRTL.size_t; - WC_Encoding : Character; + WC_Encoding : constant Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); -- Default wide character encoding diff --git a/gcc/ada/libgnat/g-binenv.adb b/gcc/ada/libgnat/g-binenv.adb index e10fb96..4bf39cd 100644 --- a/gcc/ada/libgnat/g-binenv.adb +++ b/gcc/ada/libgnat/g-binenv.adb @@ -40,7 +40,7 @@ package body GNAT.Bind_Environment is function Get (Key : String) return String is use type System.Address; - Bind_Env_Addr : System.Address; + Bind_Env_Addr : constant System.Address; pragma Import (C, Bind_Env_Addr, "__gl_bind_env_addr"); -- Variable provided by init.c/s-init.ads, and initialized by -- the binder generated file. diff --git a/gcc/ada/libgnat/s-aoinar.adb b/gcc/ada/libgnat/s-aoinar.adb index 2f430ed..41d0cda 100644 --- a/gcc/ada/libgnat/s-aoinar.adb +++ b/gcc/ada/libgnat/s-aoinar.adb @@ -72,22 +72,10 @@ package body System.Atomic_Operations.Integer_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Add_1 + function Atomic_Fetch_Add (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_1, "__atomic_fetch_add_1"); - function Atomic_Fetch_Add_2 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_2, "__atomic_fetch_add_2"); - function Atomic_Fetch_Add_4 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_4, "__atomic_fetch_add_4"); - function Atomic_Fetch_Add_8 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_8, "__atomic_fetch_add_8"); + pragma Import (Intrinsic, Atomic_Fetch_Add, "__atomic_fetch_add"); pragma Warnings (On); begin @@ -96,21 +84,14 @@ package body System.Atomic_Operations.Integer_Arithmetic is if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'Base'First = Atomic_Type'First - and then Atomic_Type'Last - in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1 + and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1 then - case Long_Long_Integer (Atomic_Type'Last) is - when 2 ** 7 - 1 => - return Atomic_Fetch_Add_1 (Item'Address, Value); - when 2 ** 15 - 1 => - return Atomic_Fetch_Add_2 (Item'Address, Value); - when 2 ** 31 - 1 => - return Atomic_Fetch_Add_4 (Item'Address, Value); - when 2 ** 63 - 1 => - return Atomic_Fetch_Add_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Add (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; @@ -138,22 +119,10 @@ package body System.Atomic_Operations.Integer_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Sub_1 + function Atomic_Fetch_Sub (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_1, "__atomic_fetch_sub_1"); - function Atomic_Fetch_Sub_2 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_2, "__atomic_fetch_sub_2"); - function Atomic_Fetch_Sub_4 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_4, "__atomic_fetch_sub_4"); - function Atomic_Fetch_Sub_8 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_8, "__atomic_fetch_sub_8"); + pragma Import (Intrinsic, Atomic_Fetch_Sub, "__atomic_fetch_sub"); pragma Warnings (On); begin @@ -162,21 +131,14 @@ package body System.Atomic_Operations.Integer_Arithmetic is if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'Base'First = Atomic_Type'First - and then Atomic_Type'Last - in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1 + and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1 then - case Long_Long_Integer (Atomic_Type'Last) is - when 2 ** 7 - 1 => - return Atomic_Fetch_Sub_1 (Item'Address, Value); - when 2 ** 15 - 1 => - return Atomic_Fetch_Sub_2 (Item'Address, Value); - when 2 ** 31 - 1 => - return Atomic_Fetch_Sub_4 (Item'Address, Value); - when 2 ** 63 - 1 => - return Atomic_Fetch_Sub_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Sub (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; diff --git a/gcc/ada/libgnat/s-aomoar.adb b/gcc/ada/libgnat/s-aomoar.adb index a6f4b0e..617a5b3 100644 --- a/gcc/ada/libgnat/s-aomoar.adb +++ b/gcc/ada/libgnat/s-aomoar.adb @@ -72,48 +72,26 @@ package body System.Atomic_Operations.Modular_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Add_1 + function Atomic_Fetch_Add (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_1, "__atomic_fetch_add_1"); - function Atomic_Fetch_Add_2 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_2, "__atomic_fetch_add_2"); - function Atomic_Fetch_Add_4 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_4, "__atomic_fetch_add_4"); - function Atomic_Fetch_Add_8 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Add_8, "__atomic_fetch_add_8"); + pragma Import (Intrinsic, Atomic_Fetch_Add, "__atomic_fetch_add"); pragma Warnings (On); begin -- Use the direct intrinsics when possible, and fallback to -- compare-and-exchange otherwise. - -- Also suppress spurious warnings. - pragma Warnings (Off); if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'First = 0 - and then Atomic_Type'Last - in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1 + and then Atomic_Type'Last = 2**Atomic_Type'Object_Size - 1 then - pragma Warnings (On); - case Unsigned_64 (Atomic_Type'Last) is - when 2 ** 8 - 1 => - return Atomic_Fetch_Add_1 (Item'Address, Value); - when 2 ** 16 - 1 => - return Atomic_Fetch_Add_2 (Item'Address, Value); - when 2 ** 32 - 1 => - return Atomic_Fetch_Add_4 (Item'Address, Value); - when 2 ** 64 - 1 => - return Atomic_Fetch_Add_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Add (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; @@ -141,48 +119,26 @@ package body System.Atomic_Operations.Modular_Arithmetic is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Fetch_Sub_1 + function Atomic_Fetch_Sub (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_1, "__atomic_fetch_sub_1"); - function Atomic_Fetch_Sub_2 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_2, "__atomic_fetch_sub_2"); - function Atomic_Fetch_Sub_4 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_4, "__atomic_fetch_sub_4"); - function Atomic_Fetch_Sub_8 - (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) - return Atomic_Type; - pragma Import (Intrinsic, Atomic_Fetch_Sub_8, "__atomic_fetch_sub_8"); + pragma Import (Intrinsic, Atomic_Fetch_Sub, "__atomic_fetch_sub"); pragma Warnings (On); begin -- Use the direct intrinsics when possible, and fallback to -- compare-and-exchange otherwise. - -- Also suppress spurious warnings. - pragma Warnings (Off); if Atomic_Type'Base'Last = Atomic_Type'Last and then Atomic_Type'First = 0 - and then Atomic_Type'Last - in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1 + and then Atomic_Type'Last = 2**Atomic_Type'Object_Size - 1 then - pragma Warnings (On); - case Unsigned_64 (Atomic_Type'Last) is - when 2 ** 8 - 1 => - return Atomic_Fetch_Sub_1 (Item'Address, Value); - when 2 ** 16 - 1 => - return Atomic_Fetch_Sub_2 (Item'Address, Value); - when 2 ** 32 - 1 => - return Atomic_Fetch_Sub_4 (Item'Address, Value); - when 2 ** 64 - 1 => - return Atomic_Fetch_Sub_8 (Item'Address, Value); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Fetch_Sub (Item'Address, Value); + else + raise Program_Error; + end if; + else declare Old_Value : aliased Atomic_Type := Item; diff --git a/gcc/ada/libgnat/s-atopex.adb b/gcc/ada/libgnat/s-atopex.adb index b0aa9e5..65e9433 100644 --- a/gcc/ada/libgnat/s-atopex.adb +++ b/gcc/ada/libgnat/s-atopex.adb @@ -43,36 +43,19 @@ package body System.Atomic_Operations.Exchange is Value : Atomic_Type) return Atomic_Type is pragma Warnings (Off); - function Atomic_Exchange_1 + function Atomic_Exchange (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_1, "__atomic_exchange_1"); - function Atomic_Exchange_2 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_2, "__atomic_exchange_2"); - function Atomic_Exchange_4 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_4, "__atomic_exchange_4"); - function Atomic_Exchange_8 - (Ptr : System.Address; - Val : Atomic_Type; - Model : Mem_Model := Seq_Cst) return Atomic_Type; - pragma Import (Intrinsic, Atomic_Exchange_8, "__atomic_exchange_8"); + pragma Import (Intrinsic, Atomic_Exchange, "__atomic_exchange_n"); pragma Warnings (On); begin - case Atomic_Type'Object_Size is - when 8 => return Atomic_Exchange_1 (Item'Address, Value); - when 16 => return Atomic_Exchange_2 (Item'Address, Value); - when 32 => return Atomic_Exchange_4 (Item'Address, Value); - when 64 => return Atomic_Exchange_8 (Item'Address, Value); - when others => raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Exchange (Item'Address, Value); + else + raise Program_Error; + end if; end Atomic_Exchange; --------------------------------- @@ -85,34 +68,7 @@ package body System.Atomic_Operations.Exchange is Desired : Atomic_Type) return Boolean is pragma Warnings (Off); - function Atomic_Compare_Exchange_1 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_1, "__atomic_compare_exchange_1"); - function Atomic_Compare_Exchange_2 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_2, "__atomic_compare_exchange_2"); - function Atomic_Compare_Exchange_4 - (Ptr : System.Address; - Expected : System.Address; - Desired : Atomic_Type; - Weak : Boolean := False; - Success_Model : Mem_Model := Seq_Cst; - Failure_Model : Mem_Model := Seq_Cst) return Boolean; - pragma Import - (Intrinsic, Atomic_Compare_Exchange_4, "__atomic_compare_exchange_4"); - function Atomic_Compare_Exchange_8 + function Atomic_Compare_Exchange (Ptr : System.Address; Expected : System.Address; Desired : Atomic_Type; @@ -120,26 +76,15 @@ package body System.Atomic_Operations.Exchange is Success_Model : Mem_Model := Seq_Cst; Failure_Model : Mem_Model := Seq_Cst) return Boolean; pragma Import - (Intrinsic, Atomic_Compare_Exchange_8, "__atomic_compare_exchange_8"); + (Intrinsic, Atomic_Compare_Exchange, "__atomic_compare_exchange_n"); pragma Warnings (On); begin - case Atomic_Type'Object_Size is - when 8 => - return - Atomic_Compare_Exchange_1 (Item'Address, Prior'Address, Desired); - when 16 => - return - Atomic_Compare_Exchange_2 (Item'Address, Prior'Address, Desired); - when 32 => - return - Atomic_Compare_Exchange_4 (Item'Address, Prior'Address, Desired); - when 64 => - return - Atomic_Compare_Exchange_8 (Item'Address, Prior'Address, Desired); - when others => - raise Program_Error; - end case; + if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then + return Atomic_Compare_Exchange (Item'Address, Prior'Address, Desired); + else + raise Program_Error; + end if; end Atomic_Compare_And_Exchange; ------------------ diff --git a/gcc/ada/libgnat/s-atopri.adb b/gcc/ada/libgnat/s-atopri.adb index ba284f0..20aa666 100644 --- a/gcc/ada/libgnat/s-atopri.adb +++ b/gcc/ada/libgnat/s-atopri.adb @@ -31,103 +31,39 @@ package body System.Atomic_Primitives is - ---------------------- - -- Lock_Free_Read_8 -- - ---------------------- + -------------------- + -- Lock_Free_Read -- + -------------------- - function Lock_Free_Read_8 (Ptr : Address) return uint8 is - begin - if uint8'Atomic_Always_Lock_Free then - return Atomic_Load_8 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_8; - - ----------------------- - -- Lock_Free_Read_16 -- - ----------------------- + function Lock_Free_Read (Ptr : Address) return Atomic_Type is + function My_Atomic_Load is new Atomic_Load (Atomic_Type); - function Lock_Free_Read_16 (Ptr : Address) return uint16 is begin - if uint16'Atomic_Always_Lock_Free then - return Atomic_Load_16 (Ptr, Acquire); + if Atomic_Type'Atomic_Always_Lock_Free then + return My_Atomic_Load (Ptr, Acquire); else raise Program_Error; end if; - end Lock_Free_Read_16; + end Lock_Free_Read; - ----------------------- - -- Lock_Free_Read_32 -- - ----------------------- - - function Lock_Free_Read_32 (Ptr : Address) return uint32 is - begin - if uint32'Atomic_Always_Lock_Free then - return Atomic_Load_32 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_32; + ------------------------- + -- Lock_Free_Try_Write -- + ------------------------- - ----------------------- - -- Lock_Free_Read_64 -- - ----------------------- - - function Lock_Free_Read_64 (Ptr : Address) return uint64 is - begin - if uint64'Atomic_Always_Lock_Free then - return Atomic_Load_64 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_64; - - --------------------------- - -- Lock_Free_Try_Write_8 -- - --------------------------- - - function Lock_Free_Try_Write_8 + function Lock_Free_Try_Write (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean + Expected : in out Atomic_Type; + Desired : Atomic_Type) return Boolean is - Actual : uint8; + function My_Sync_Compare_And_Swap is + new Sync_Compare_And_Swap (Atomic_Type); - begin - if Expected /= Desired then - - if uint8'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_8 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_8; - - ---------------------------- - -- Lock_Free_Try_Write_16 -- - ---------------------------- - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean - is - Actual : uint16; + Actual : Atomic_Type; begin if Expected /= Desired then - - if uint16'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_16 (Ptr, Expected, Desired); + if Atomic_Type'Atomic_Always_Lock_Free then + Actual := My_Sync_Compare_And_Swap (Ptr, Expected, Desired); else raise Program_Error; end if; @@ -139,63 +75,6 @@ package body System.Atomic_Primitives is end if; return True; - end Lock_Free_Try_Write_16; - - ---------------------------- - -- Lock_Free_Try_Write_32 -- - ---------------------------- + end Lock_Free_Try_Write; - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean - is - Actual : uint32; - - begin - if Expected /= Desired then - - if uint32'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_32 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_32; - - ---------------------------- - -- Lock_Free_Try_Write_64 -- - ---------------------------- - - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean - is - Actual : uint64; - - begin - if Expected /= Desired then - - if uint64'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_64 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_64; end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-atopri.ads b/gcc/ada/libgnat/s-atopri.ads index 891b2ed..ea03f1a 100644 --- a/gcc/ada/libgnat/s-atopri.ads +++ b/gcc/ada/libgnat/s-atopri.ads @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- This package contains both atomic primitives defined from gcc built-in +-- This package contains both atomic primitives defined from GCC built-in -- functions and operations used by the compiler to generate the lock-free -- implementation of protected objects. @@ -66,71 +66,31 @@ package System.Atomic_Primitives is -- GCC built-in atomic primitives -- ------------------------------------ - function Atomic_Load_8 + generic + type Atomic_Type is mod <>; + function Atomic_Load (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint8; - pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + Model : Mem_Model := Seq_Cst) return Atomic_Type; + pragma Import (Intrinsic, Atomic_Load, "__atomic_load_n"); - function Atomic_Load_16 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint16; - pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); - - function Atomic_Load_32 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint32; - pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); - - function Atomic_Load_64 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint64; - pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); - - function Sync_Compare_And_Swap_8 - (Ptr : Address; - Expected : uint8; - Desired : uint8) return uint8; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_8, - "__sync_val_compare_and_swap_1"); - - function Sync_Compare_And_Swap_16 - (Ptr : Address; - Expected : uint16; - Desired : uint16) return uint16; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_16, - "__sync_val_compare_and_swap_2"); + function Atomic_Load_8 is new Atomic_Load (uint8); + function Atomic_Load_16 is new Atomic_Load (uint16); + function Atomic_Load_32 is new Atomic_Load (uint32); + function Atomic_Load_64 is new Atomic_Load (uint64); - function Sync_Compare_And_Swap_32 + generic + type Atomic_Type is mod <>; + function Sync_Compare_And_Swap (Ptr : Address; - Expected : uint32; - Desired : uint32) return uint32; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_32, - "__sync_val_compare_and_swap_4"); + Expected : Atomic_Type; + Desired : Atomic_Type) return Atomic_Type; + pragma Import + (Intrinsic, Sync_Compare_And_Swap, "__sync_val_compare_and_swap"); - function Sync_Compare_And_Swap_64 - (Ptr : Address; - Expected : uint64; - Desired : uint64) return uint64; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_64, - "__sync_val_compare_and_swap_8"); - - -- ??? We might want to switch to the __atomic series of builtins for - -- compare-and-swap operations at some point. - - -- function Atomic_Compare_Exchange_8 - -- (Ptr : Address; - -- Expected : Address; - -- Desired : uint8; - -- Weak : Boolean := False; - -- Success_Model : Mem_Model := Seq_Cst; - -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; - -- pragma Import (Intrinsic, - -- Atomic_Compare_Exchange_8, - -- "__atomic_compare_exchange_1"); + function Sync_Compare_And_Swap_8 is new Sync_Compare_And_Swap (uint8); + function Sync_Compare_And_Swap_16 is new Sync_Compare_And_Swap (uint16); + function Sync_Compare_And_Swap_32 is new Sync_Compare_And_Swap (uint32); + function Sync_Compare_And_Swap_64 is new Sync_Compare_And_Swap (uint64); function Atomic_Test_And_Set (Ptr : System.Address; @@ -155,46 +115,37 @@ package System.Atomic_Primitives is -- The lock-free implementation uses two atomic instructions for the -- expansion of protected operations: - -- * Lock_Free_Read_N atomically loads the value of the protected component - -- accessed by the current protected operation. - - -- * Lock_Free_Try_Write_N tries to write the Desired value into Ptr only - -- if Expected and Desired mismatch. + -- * Lock_Free_Read atomically loads the value contained in Ptr (with the + -- Acquire synchronization mode). - function Lock_Free_Read_8 (Ptr : Address) return uint8; + -- * Lock_Free_Try_Write atomically tries to write the Desired value into + -- Ptr if Ptr contains the Expected value. It returns true if the value + -- in Ptr was changed, or False if it was not, in which case Expected is + -- updated to the unexpected value in Ptr. Note that it does nothing and + -- returns true if Desired and Expected are equal. - function Lock_Free_Read_16 (Ptr : Address) return uint16; + generic + type Atomic_Type is mod <>; + function Lock_Free_Read (Ptr : Address) return Atomic_Type; - function Lock_Free_Read_32 (Ptr : Address) return uint32; + function Lock_Free_Read_8 is new Lock_Free_Read (uint8); + function Lock_Free_Read_16 is new Lock_Free_Read (uint16); + function Lock_Free_Read_32 is new Lock_Free_Read (uint32); + function Lock_Free_Read_64 is new Lock_Free_Read (uint64); - function Lock_Free_Read_64 (Ptr : Address) return uint64; - - function Lock_Free_Try_Write_8 - (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean; - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean; - - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean; + generic + type Atomic_Type is mod <>; + function Lock_Free_Try_Write + (Ptr : Address; + Expected : in out Atomic_Type; + Desired : Atomic_Type) return Boolean; - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean; + function Lock_Free_Try_Write_8 is new Lock_Free_Try_Write (uint8); + function Lock_Free_Try_Write_16 is new Lock_Free_Try_Write (uint16); + function Lock_Free_Try_Write_32 is new Lock_Free_Try_Write (uint32); + function Lock_Free_Try_Write_64 is new Lock_Free_Try_Write (uint64); - pragma Inline (Lock_Free_Read_8); - pragma Inline (Lock_Free_Read_16); - pragma Inline (Lock_Free_Read_32); - pragma Inline (Lock_Free_Read_64); - pragma Inline (Lock_Free_Try_Write_8); - pragma Inline (Lock_Free_Try_Write_16); - pragma Inline (Lock_Free_Try_Write_32); - pragma Inline (Lock_Free_Try_Write_64); +private + pragma Inline (Lock_Free_Read); + pragma Inline (Lock_Free_Try_Write); end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb index 9001626..09a65ee 100644 --- a/gcc/ada/libgnat/s-parame.adb +++ b/gcc/ada/libgnat/s-parame.adb @@ -55,7 +55,7 @@ package body System.Parameters is ------------------------ function Default_Stack_Size return Size_Type is - Default_Stack_Size : Integer; + Default_Stack_Size : constant Integer; pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); begin if Default_Stack_Size = -1 then diff --git a/gcc/ada/libgnat/s-parame__ae653.ads b/gcc/ada/libgnat/s-parame__ae653.ads deleted file mode 100644 index f838b41..0000000 --- a/gcc/ada/libgnat/s-parame__ae653.ads +++ /dev/null @@ -1,192 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2021, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version is used by VxWorks 653, VxWorks MILS, and VxWorks6 cert Ravenscar - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Size_Type is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; - -- Type used to provide task stack sizes to the runtime. Sized to permit - -- stack sizes of up to half the total addressable memory space. This may - -- seem excessively large (even for 32-bit systems), however there are many - -- instances of users requiring large stack sizes (for example string - -- processing). - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 14_336; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; - -- The run-time chosen default size for secondary stacks that may be - -- overridden by the user with the use of binder -D switch. - - Sec_Stack_Dynamic : constant Boolean := False; - -- Indicates if secondary stacks can grow and shrink at run-time. If False, - -- the size of a secondary stack is fixed at the point of its creation. - - ------------------------------------ - -- Characteristics of time_t type -- - ------------------------------------ - - time_t_bits : constant := Long_Integer'Size; - -- Number of bits in type time_t - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- of all targets. - - ptr_bits : constant := Standard'Address_Size; - subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address - - C_Malloc_Linkname : constant String := "__gnat_malloc"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 8; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 32; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 200; - -- This constant specifies the default number of characters to allow - -- in an exception message (200 is minimum required by RM 11.4.1(18)). - -end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb index 1a6d577..ae88a2c 100644 --- a/gcc/ada/libgnat/s-parame__rtems.adb +++ b/gcc/ada/libgnat/s-parame__rtems.adb @@ -35,10 +35,6 @@ with Interfaces.C; package body System.Parameters is - function ada_pthread_minimum_stack_size return Interfaces.C.size_t; - pragma Import (C, ada_pthread_minimum_stack_size, - "_ada_pthread_minimum_stack_size"); - ------------------------- -- Adjust_Storage_Size -- ------------------------- @@ -61,8 +57,15 @@ package body System.Parameters is ------------------------ function Default_Stack_Size return Size_Type is + Default_Stack_Size : constant Integer + with Import, Convention => C, + External_Name => "__gl_default_stack_size"; begin - return Size_Type (ada_pthread_minimum_stack_size); + if Default_Stack_Size = -1 then + return 32 * 1024; + else + return Size_Type (Default_Stack_Size); + end if; end Default_Stack_Size; ------------------------ @@ -70,9 +73,11 @@ package body System.Parameters is ------------------------ function Minimum_Stack_Size return Size_Type is - + POSIX_Threads_Minimum_stack_size : constant Interfaces.C.size_t + with Import, Convention => C, + External_Name => "_POSIX_Threads_Minimum_stack_size"; begin - return Size_Type (ada_pthread_minimum_stack_size); + return Size_Type (POSIX_Threads_Minimum_stack_size); end Minimum_Stack_Size; end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb index 5970eb0..45ee0a9 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.adb +++ b/gcc/ada/libgnat/s-parame__vxworks.adb @@ -53,7 +53,7 @@ package body System.Parameters is ------------------------ function Default_Stack_Size return Size_Type is - Default_Stack_Size : Integer; + Default_Stack_Size : constant Integer; pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); begin if Default_Stack_Size = -1 then diff --git a/gcc/ada/libgnat/s-stchop__rtems.adb b/gcc/ada/libgnat/s-stchop__rtems.adb deleted file mode 100644 index f273f29..0000000 --- a/gcc/ada/libgnat/s-stchop__rtems.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2021, Free Software Foundation, Inc. -- --- -- --- GNARL 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the RTEMS version of this package. --- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with Ada.Exceptions; - -with Interfaces.C; use Interfaces.C; - -package body System.Stack_Checking.Operations is - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - pragma Warnings (Off, Any_Stack); - begin - Cache := Null_Stack; - end Invalidate_Stack_Cache; - - ----------------------------- - -- Notify_Stack_Attributes -- - ----------------------------- - - procedure Notify_Stack_Attributes - (Initial_SP : System.Address; - Size : System.Storage_Elements.Storage_Offset) - is - - -- RTEMS keeps all the information we need. - - pragma Unreferenced (Size); - pragma Unreferenced (Initial_SP); - - begin - null; - end Notify_Stack_Attributes; - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check - (Stack_Address : System.Address) return Stack_Access - is - pragma Unreferenced (Stack_Address); - - -- RTEMS has a routine to check if the stack is blown. - -- It returns a C99 bool. - function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; - pragma Import (C, - rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); - - begin - -- RTEMS has a routine to check this. So use it. - - if rtems_stack_checker_is_blown /= 0 then - Ada.Exceptions.Raise_Exception - (E => Storage_Error'Identity, - Message => "stack overflow detected"); - end if; - - return null; - - end Stack_Check; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - if not Multi_Processor then - Cache := Stack; - end if; - end Update_Stack_Cache; - -end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb index 5f04153..d7f572e 100644 --- a/gcc/ada/libgnat/s-stratt.adb +++ b/gcc/ada/libgnat/s-stratt.adb @@ -36,13 +36,13 @@ with System.Stream_Attributes.XDR; package body System.Stream_Attributes is - XDR_Flag : Integer; - pragma Import (C, XDR_Flag, "__gl_xdr_stream"); + XDR_Stream : constant Integer; + pragma Import (C, XDR_Stream, "__gl_xdr_stream"); -- This imported value is used to determine whether the build had the -- binder switch "-xdr" present which enables XDR streaming and sets this -- flag to 1. - function XDR_Support return Boolean; + function XDR_Support return Boolean is (XDR_Stream = 1); pragma Inline (XDR_Support); -- Return True if XDR streaming should be used. Note that 128-bit integers -- are not supported by the XDR protocol and will raise Device_Error. @@ -142,15 +142,6 @@ package body System.Stream_Attributes is function To_WWC is new UC (S_WWC, Wide_Wide_Character); ----------------- - -- XDR_Support -- - ----------------- - - function XDR_Support return Boolean is - begin - return XDR_Flag = 1; - end XDR_Support; - - ----------------- -- Block_IO_OK -- ----------------- diff --git a/gcc/ada/libgnat/s-thread.ads b/gcc/ada/libgnat/s-thread.ads deleted file mode 100644 index 5d0a3c1..0000000 --- a/gcc/ada/libgnat/s-thread.ads +++ /dev/null @@ -1,92 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T H R E A D S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2021, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides facilities to register a thread to the runtime, --- and allocate its task specific datas. - --- This package is currently implemented for: - --- VxWorks AE653 rts-cert --- VxWorks AE653 rts-full (not rts-kernel) - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.Secondary_Stack; -with System.Soft_Links; - -package System.Threads is - - package SST renames System.Secondary_Stack; - - type ATSD is limited private; - -- Type of the Ada thread specific data. It contains datas needed - -- by the GNAT runtime. - - type ATSD_Access is access ATSD; - function From_Address is - new Ada.Unchecked_Conversion (Address, ATSD_Access); - - subtype STATUS is Interfaces.C.int; - -- Equivalent of the C type STATUS - - type t_id is new Interfaces.C.long; - subtype Thread_Id is t_id; - - function Register (T : Thread_Id) return STATUS; - -- Create the task specific data necessary for Ada language support - - -------------------------- - -- Thread Body Handling -- - -------------------------- - - -- The subprograms in this section are called from the process body - -- wrapper in the APEX process registration package. - - procedure Thread_Body_Enter - (Sec_Stack_Ptr : SST.SS_Stack_Ptr; - Process_ATSD_Address : System.Address); - -- Enter thread body, see above for details - - procedure Thread_Body_Leave; - -- Leave thread body (normally), see above for details - - procedure Thread_Body_Exceptional_Exit - (EO : Ada.Exceptions.Exception_Occurrence); - -- Leave thread body (abnormally on exception), see above for details - -private - - type ATSD is new System.Soft_Links.TSD; - -end System.Threads; diff --git a/gcc/ada/libgnat/s-thread__ae653.adb b/gcc/ada/libgnat/s-thread__ae653.adb deleted file mode 100644 index ecbd415..0000000 --- a/gcc/ada/libgnat/s-thread__ae653.adb +++ /dev/null @@ -1,227 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T H R E A D S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2021, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks 653 version of this package - -pragma Restrictions (No_Tasking); --- The VxWorks 653 version of this package is intended only for programs --- which do not use Ada tasking. This restriction ensures that this --- will be checked by the binder. - -with System.Storage_Elements; use System.Storage_Elements; -with System.OS_Versions; use System.OS_Versions; - -package body System.Threads is - - use Interfaces.C; - - package SSL renames System.Soft_Links; - - Main_ATSD : aliased ATSD; - -- TSD for environment task - - Current_ATSD : aliased System.Address := System.Null_Address; - pragma Thread_Local_Storage (Current_ATSD); - -- pragma TLS needed since TaskVarAdd no longer available - - -- Assume guard pages for Helix APEX partitions, but leave - -- checking mechanism in for now, in case of surprises. ??? - Stack_Limit : Address; - pragma Import (C, Stack_Limit, "__gnat_stack_limit"); - - type Set_Stack_Limit_Proc_Acc is access procedure; - pragma Convention (C, Set_Stack_Limit_Proc_Acc); - - Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; - pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); - -- Procedure to be called when a task is created to set stack limit if - -- limit checking is used. - - -- VxWorks specific API - - ERROR : constant STATUS := Interfaces.C.int (-1); - OK : constant STATUS := Interfaces.C.int (0); - - function taskIdVerify (tid : t_id) return STATUS; - pragma Import (C, taskIdVerify, "taskIdVerify"); - - function taskIdSelf return t_id; - pragma Import (C, taskIdSelf, "taskIdSelf"); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Init_RTS; - -- This procedure performs the initialization of the run-time lib. - -- It installs System.Threads versions of certain operations of the - -- run-time lib. - - procedure Install_Handler; - pragma Import (C, Install_Handler, "__gnat_install_handler"); - - function Get_Sec_Stack return SST.SS_Stack_Ptr; - - procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); - - ----------------------- - -- Thread_Body_Enter -- - ----------------------- - - procedure Thread_Body_Enter - (Sec_Stack_Ptr : SST.SS_Stack_Ptr; - Process_ATSD_Address : System.Address) - is - - ATSD : constant ATSD_Access := From_Address (Process_ATSD_Address); - - begin - - ATSD.Sec_Stack_Ptr := Sec_Stack_Ptr; - SST.SS_Init (ATSD.Sec_Stack_Ptr); - Current_ATSD := Process_ATSD_Address; - Install_Handler; - - -- Assume guard pages for Helix/Vx7, but leave in for now ??? - -- Initialize stack limit if needed. - - if Current_ATSD /= Main_ATSD'Address - and then Set_Stack_Limit_Hook /= null - then - Set_Stack_Limit_Hook.all; - end if; - end Thread_Body_Enter; - - ---------------------------------- - -- Thread_Body_Exceptional_Exit -- - ---------------------------------- - - procedure Thread_Body_Exceptional_Exit - (EO : Ada.Exceptions.Exception_Occurrence) - is - pragma Unreferenced (EO); - - begin - -- No action for this target - - null; - end Thread_Body_Exceptional_Exit; - - ----------------------- - -- Thread_Body_Leave -- - ----------------------- - - procedure Thread_Body_Leave is - begin - -- No action for this target - - null; - end Thread_Body_Leave; - - -------------- - -- Init_RTS -- - -------------- - - procedure Init_RTS is - -- Register environment task - Result : constant Interfaces.C.int := Register (taskIdSelf); - pragma Assert (Result /= ERROR); - - begin - Main_ATSD.Sec_Stack_Ptr := SSL.Get_Sec_Stack_NT; - Current_ATSD := Main_ATSD'Address; - Install_Handler; - SSL.Get_Sec_Stack := Get_Sec_Stack'Access; - SSL.Set_Sec_Stack := Set_Sec_Stack'Access; - end Init_RTS; - - ------------------- - -- Get_Sec_Stack -- - ------------------- - - function Get_Sec_Stack return SST.SS_Stack_Ptr is - CTSD : constant ATSD_Access := From_Address (Current_ATSD); - begin - pragma Assert (CTSD /= null); - return CTSD.Sec_Stack_Ptr; - end Get_Sec_Stack; - - -------------- - -- Register -- - -------------- - - function Register (T : Thread_Id) return STATUS is - begin - -- It cannot be assumed that the caller of this routine has a ATSD; - -- so neither this procedure nor the procedures that it calls should - -- raise or handle exceptions, or make use of a secondary stack. - - if taskIdVerify (T) = ERROR then - return ERROR; - end if; - - Current_ATSD := To_Address (Integer_Address (T)); - - -- The same issue applies to the task variable that contains the stack - -- limit when that overflow checking mechanism is used instead of - -- probing. If stack checking is enabled and limit checking is used, - -- allocate the limit for this task. The environment task has this - -- initialized by the binder-generated main when - -- System.Stack_Check_Limits = True. - - pragma Warnings (Off); - - -- OS is a constant - if OS /= VxWorks_653 and then Set_Stack_Limit_Hook /= null then - -- Check that this is correct if limit checking left in. ??? - Stack_Limit := To_Address (Integer_Address (T)); - end if; - pragma Warnings (On); - - return OK; - end Register; - - ------------------- - -- Set_Sec_Stack -- - ------------------- - - procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is - CTSD : constant ATSD_Access := From_Address (Current_ATSD); - begin - pragma Assert (CTSD /= null); - CTSD.Sec_Stack_Ptr := Stack; - end Set_Sec_Stack; - -begin - -- Initialize run-time library - - Init_RTS; -end System.Threads; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 61e7a1c..fb26d77 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -691,7 +691,7 @@ package body System.Traceback.Symbolic is return Symbolic_Traceback (E, Suppress_Hex => True); end Symbolic_Traceback_No_Hex; - Exception_Tracebacks_Symbolic : Integer; + Exception_Tracebacks_Symbolic : constant Integer; pragma Import (C, Exception_Tracebacks_Symbolic, diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads index 018e740..10a0c9c 100644 --- a/gcc/ada/libgnat/s-widlllu.ads +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -34,8 +34,9 @@ with System.Width_U; with System.Unsigned_Types; -package System.Wid_LLLU is - +package System.Wid_LLLU + with SPARK_Mode +is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; function Width_Long_Long_Long_Unsigned is diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index ab7ec58..7eaf966 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -34,8 +34,9 @@ with System.Width_U; with System.Unsigned_Types; -package System.Wid_LLU is - +package System.Wid_LLU + with SPARK_Mode +is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; function Width_Long_Long_Unsigned is new Width_U (Long_Long_Unsigned); diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index a91baec..fce8c7a 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -29,10 +29,87 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + function System.Width_U (Lo, Hi : Uns) return Natural is + + -- Ghost code, loop invariants and assertions in this unit are meant for + -- analysis only, not for run-time checking, as it would be too costly + -- otherwise. This is enforced by setting the assertion policy to Ignore. + + pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + W : Natural; T : Uns; + package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); + + function Big (Arg : Uns) return Big_Integer is + (Unsigned_Conversion.To_Big_Integer (Arg)) + with Ghost; + + -- Maximum value of exponent for 10 that fits in Uns'Base + function Max_Log10 return Natural is + (case Uns'Base'Size is + when 8 => 2, + when 16 => 4, + when 32 => 9, + when 64 => 19, + when 128 => 38, + when others => raise Program_Error) + with Ghost; + + Max_W : constant Natural := Max_Log10 with Ghost; + Big_10 : constant Big_Integer := Big (10) with Ghost; + + procedure Lemma_Lower_Mult (A, B, C : Big_Natural) + with + Ghost, + Pre => A <= B, + Post => A * C <= B * C; + + procedure Lemma_Div_Commutation (X, Y : Uns) + with + Ghost, + Pre => Y /= 0, + Post => Big (X) / Big (Y) = Big (X / Y); + + procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) + with + Ghost, + Post => X / Y / Z = X / (Y * Z); + + procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is + begin + null; + end Lemma_Lower_Mult; + + procedure Lemma_Div_Commutation (X, Y : Uns) is + begin + null; + end Lemma_Div_Commutation; + + procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is + XY : constant Big_Natural := X / Y; + YZ : constant Big_Natural := Y * Z; + XYZ : constant Big_Natural := X / Y / Z; + R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); + begin + pragma Assert (X = XY * Y + (X rem Y)); + pragma Assert (XY = XY / Z * Z + (XY rem Z)); + pragma Assert (X = XYZ * YZ + R); + pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); + pragma Assert (R <= YZ - 1); + pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); + pragma Assert (X / YZ = XYZ + R / YZ); + end Lemma_Div_Twice; + + Pow : Big_Integer := 1 with Ghost; + T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost; + begin if Lo > Hi then return 0; @@ -50,10 +127,43 @@ begin -- Increase value if more digits required while T >= 10 loop + Lemma_Div_Commutation (T, 10); + Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); + T := T / 10; W := W + 1; + Pow := Pow * 10; + + pragma Loop_Invariant (W in 3 .. Max_W + 3); + pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); + pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); + pragma Loop_Variant (Decreases => T); + pragma Annotate + (CodePeer, False_Positive, + "validity check", "confusion on generated code"); end loop; + declare + F : constant Big_Integer := Big_10 ** (W - 2) with Ghost; + Q : constant Big_Integer := Big (T_Init) / F with Ghost; + R : constant Big_Integer := Big (T_Init) rem F with Ghost; + begin + pragma Assert (Q < Big_10); + pragma Assert (Big (T_Init) = Q * F + R); + Lemma_Lower_Mult (Q, Big (9), F); + pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); + pragma Assert (Big (T_Init) < Big_10 * F); + pragma Assert (Big_10 * F = Big_10 ** (W - 1)); + end; + + -- This is an expression of the functional postcondition for Width_U, + -- which cannot be expressed readily as a postcondition as this would + -- require making the instantiation Unsigned_Conversion and function + -- Big available from the spec. + + pragma Assert (Big (Lo) < Big_10 ** (W - 1)); + pragma Assert (Big (Hi) < Big_10 ** (W - 1)); + return W; end if; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads index 0528456..713532e 100644 --- a/gcc/ada/libgnat/s-widuns.ads +++ b/gcc/ada/libgnat/s-widuns.ads @@ -34,8 +34,9 @@ with System.Width_U; with System.Unsigned_Types; -package System.Wid_Uns is - +package System.Wid_Uns + with SPARK_Mode +is subtype Unsigned is Unsigned_Types.Unsigned; function Width_Unsigned is new Width_U (Unsigned); diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads deleted file mode 100644 index b918c18..0000000 --- a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks/HIE Ravenscar Version PPC) -- --- -- --- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a Ravenscar VxWorks version of this package for PowerPC targets - -pragma Restrictions (No_Exception_Propagation); --- Only local exception handling is supported in this profile - -pragma Restrictions (No_Exception_Registration); --- Disable exception name registration. This capability is not used because --- it is only required by exception stream attributes which are not supported --- in this run time. - -pragma Restrictions (No_Implicit_Dynamic_Code); --- Pointers to nested subprograms are not allowed in this run time, in order --- to prevent the compiler from building "trampolines". - -pragma Restrictions (No_Finalization); --- Controlled types are not supported in this run time - -pragma Profile (Ravenscar); --- This is a Ravenscar run time - -pragma Discard_Names; --- Disable explicitly the generation of names associated with entities in --- order to reduce the amount of storage used. These names are not used anyway --- (attributes such as 'Image and 'Value are not supported in this run time). - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := True; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := True; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := True; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := True; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads deleted file mode 100644 index 8f384e9..0000000 --- a/gcc/ada/libgnat/system-vxworks-ppc.ads +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 5 Version PPC) -- --- -- --- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads deleted file mode 100644 index 6f952a2..0000000 --- a/gcc/ada/libgnat/system-vxworks-x86.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 5 Version x86) -- --- -- --- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index f02934a..76f0edd 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -532,13 +532,14 @@ package body Ch10 is | N_Subprogram_Body | N_Subprogram_Renaming_Declaration then - Unit_Node := Specification (Unit_Node); - - elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then - if Ada_Version = Ada_83 then + if Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration + and then Ada_Version = Ada_83 + then Error_Msg_N ("(Ada 83) library unit renaming not allowed", Unit_Node); end if; + + Unit_Node := Specification (Unit_Node); end if; if Nkind (Unit_Node) in N_Task_Body diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index f4179b9..1d7283c 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -816,7 +816,7 @@ package body Util is C : constant Entity_Id := Current_Entity (N); begin if Present (C) and then Sloc (C) = Standard_Location then - Error_Msg_N ("redefinition of entity& in Standard?K?", N); + Error_Msg_N ("redefinition of entity& in Standard?.k?", N); end if; end; end if; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 084ca91..b86885c 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -367,46 +367,48 @@ package body Repinfo is null; else - -- If Esize and RM_Size are the same, list as Size. This is a common - -- case, which we may as well list in simple form. + if Known_Esize (Ent) and then Known_RM_Size (Ent) then + -- If Esize and RM_Size are the same, list as Size. This is a + -- common case, which we may as well list in simple form. - if Esize (Ent) = RM_Size (Ent) then - if List_Representation_Info_To_JSON then - Write_Str (" ""Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); - end if; + if Esize (Ent) = RM_Size (Ent) then + if List_Representation_Info_To_JSON then + Write_Str (" ""Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; - -- Otherwise list size values separately + -- Otherwise list size values separately - else - if List_Representation_Info_To_JSON then - Write_Str (" ""Object_Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); + else + if List_Representation_Info_To_JSON then + Write_Str (" ""Object_Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); - Write_Str (" ""Value_Size"": "); - Write_Val (RM_Size (Ent)); - Write_Line (","); + Write_Str (" ""Value_Size"": "); + Write_Val (RM_Size (Ent)); + Write_Line (","); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Object_Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); - - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Value_Size use "); - Write_Val (RM_Size (Ent)); - Write_Line (";"); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Object_Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Value_Size use "); + Write_Val (RM_Size (Ent)); + Write_Line (";"); + end if; end if; end if; end if; @@ -569,7 +571,7 @@ package body Repinfo is -- as for some Java bindings and for generic instances). if Ekind (E) = E_Package then - if No (Renamed_Object (E)) then + if No (Renamed_Entity (E)) then List_Entities (E, Bytes_Big_Endian); end if; @@ -2118,7 +2120,7 @@ package body Repinfo is function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is - function B (Val : Boolean) return Uint; + function B (Val : Boolean) return Ubool; -- Returns Uint_0 for False, Uint_1 for True function T (Val : Node_Ref_Or_Val) return Boolean; @@ -2139,7 +2141,7 @@ package body Repinfo is -- B -- ------- - function B (Val : Boolean) return Uint is + function B (Val : Boolean) return Ubool is begin if Val then return Uint_1; diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 606bba4..d07208e 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -118,12 +118,12 @@ package Repinfo is -- this field is done only in -gnatR3 mode, and in other modes, the value -- is set to Uint_Minus_1. - subtype Node_Ref is Uint; + subtype Node_Ref is Unegative; -- Subtype used for negative Uint values used to represent nodes subtype Node_Ref_Or_Val is Uint; - -- Subtype used for values that can either be a Node_Ref (negative) - -- or a value (non-negative) + -- Subtype used for values that can be a Node_Ref (negative) or a value + -- (non-negative) or No_Uint. type TCode is range 0 .. 27; -- Type used on Ada side to represent DEFTREECODE values defined in @@ -306,7 +306,7 @@ package Repinfo is -- In the case of components, if the location of the component is static, -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize, -- and Normalized_First_Bit) are set to appropriate values. In the case of - -- a non-static component location, Component_Bit_Offset is not used and + -- a nonstatic component location, Component_Bit_Offset is not used and -- is left set to Unknown. Normalized_Position and Normalized_First_Bit -- are set appropriately. diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index eec85c2..183973b 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -402,6 +402,8 @@ package Restrict is -- Test to see if current restrictions settings specify that no -- exception propagation is activated. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; -- Id is a node whose Chars field contains the name of a restriction. -- If it is one of synonyms that we allow for historical purposes (for diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 3eee2ee..ee5c7cf 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1022,16 +1022,20 @@ package body Sem is Scop : Entity_Id; begin - -- Entity is global if defined outside of current outer_generic_scope: - -- Either the entity has a smaller depth that the outer generic, or it + -- Entity is global if defined outside of current Outer_Generic_Scope: + -- Either the entity has a smaller depth than the outer generic, or it -- is in a different compilation unit, or it is defined within a unit - -- in the same compilation, that is not within the outer_generic. + -- in the same compilation, that is not within the outer generic. if No (Outer_Generic_Scope) then return False; - elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) - or else not In_Same_Source_Unit (E, Outer_Generic_Scope) + -- It makes no sense to compare depths if not in same unit. Scope_Depth + -- is not set for inherited operations. + + elsif not In_Same_Source_Unit (E, Outer_Generic_Scope) + or else not Scope_Depth_Set (Scope (E)) + or else Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope) then return True; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9ae5ff6..42fb610 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3384,9 +3384,8 @@ package body Sem_Aggr is function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean; -- Determine whether variant V1 is within variant V2 - function Variant_Depth (N : Node_Id) return Integer; - -- Determine the distance of a variant to the enclosing type - -- declaration. + function Variant_Depth (N : Node_Id) return Natural; + -- Determine the distance of a variant to the enclosing type declaration -------------------- -- Check_Variant -- @@ -3492,8 +3491,8 @@ package body Sem_Aggr is -- Variant_Depth -- ------------------- - function Variant_Depth (N : Node_Id) return Integer is - Depth : Integer; + function Variant_Depth (N : Node_Id) return Natural is + Depth : Natural; Par : Node_Id; begin @@ -3546,7 +3545,19 @@ package body Sem_Aggr is end loop; pragma Assert (Present (Comp_Type)); - Analyze_And_Resolve (Expression (Assoc), Comp_Type); + + -- A record_component_association in record_delta_aggregate shall not + -- use the box compound delimiter <> rather than an expression; see + -- RM 4.3.1(17.3/5). + + pragma Assert (Present (Expression (Assoc)) xor Box_Present (Assoc)); + + if Box_Present (Assoc) then + Error_Msg_N + ("'<'> in record delta aggregate is not allowed", Assoc); + else + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + end if; Next (Assoc); end loop; end Resolve_Delta_Record_Aggregate; @@ -5307,8 +5318,8 @@ package body Sem_Aggr is Add_Association (Component => Component, - Expr => Empty, - Assoc_List => New_Assoc_List, + Expr => Empty, + Assoc_List => New_Assoc_List, Is_Box_Present => True); elsif Present (Parent (Component)) @@ -5387,74 +5398,12 @@ package body Sem_Aggr is Assoc_List => New_Assoc_List); Set_Has_Self_Reference (N); - -- A box-defaulted access component gets the value null. Also - -- included are components of private types whose underlying - -- type is an access type. In either case set the type of the - -- literal, for subsequent use in semantic checks. - - elsif Present (Underlying_Type (Ctyp)) - and then Is_Access_Type (Underlying_Type (Ctyp)) - then - -- If the component's type is private with an access type as - -- its underlying type then we have to create an unchecked - -- conversion to satisfy type checking. - - if Is_Private_Type (Ctyp) then - declare - Qual_Null : constant Node_Id := - Make_Qualified_Expression (Sloc (N), - Subtype_Mark => - New_Occurrence_Of - (Underlying_Type (Ctyp), Sloc (N)), - Expression => Make_Null (Sloc (N))); - - Convert_Null : constant Node_Id := - Unchecked_Convert_To - (Ctyp, Qual_Null); - - begin - Analyze_And_Resolve (Convert_Null, Ctyp); - Add_Association - (Component => Component, - Expr => Convert_Null, - Assoc_List => New_Assoc_List); - end; - - -- Otherwise the component type is non-private - - else - Expr := Make_Null (Sloc (N)); - Set_Etype (Expr, Ctyp); - - Add_Association - (Component => Component, - Expr => Expr, - Assoc_List => New_Assoc_List); - end if; - - -- Ada 2012: If component is scalar with default value, use it - -- by converting it to Ctyp, so that subtype constraints are - -- checked. - - elsif Is_Scalar_Type (Ctyp) - and then Has_Default_Aspect (Ctyp) - then - declare - Conv : constant Node_Id := - Convert_To - (Typ => Ctyp, - Expr => - New_Copy_Tree - (Default_Aspect_Value - (First_Subtype (Underlying_Type (Ctyp))))); - - begin - Analyze_And_Resolve (Conv, Ctyp); - Add_Association - (Component => Component, - Expr => Conv, - Assoc_List => New_Assoc_List); - end; + elsif Needs_Simple_Initialization (Ctyp) then + Add_Association + (Component => Component, + Expr => Empty, + Assoc_List => New_Assoc_List, + Is_Box_Present => True); elsif Has_Non_Null_Base_Init_Proc (Ctyp) or else not Expander_Active diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 4d69d58..e1ee09e 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1413,6 +1413,15 @@ package body Sem_Attr is return; end if; + -- 'Old attribute reference ok in a _Postconditions procedure + + elsif Nkind (Prag) = N_Subprogram_Body + and then not Comes_From_Source (Prag) + and then Nkind (Corresponding_Spec (Prag)) = N_Defining_Identifier + and then Chars (Corresponding_Spec (Prag)) = Name_uPostconditions + then + null; + -- Otherwise the placement of the attribute is illegal else @@ -1424,6 +1433,15 @@ package body Sem_Attr is if Nkind (Prag) = N_Aspect_Specification then Subp_Decl := Parent (Prag); + elsif Nkind (Prag) = N_Subprogram_Body then + declare + Enclosing_Scope : constant Node_Id := + Scope (Corresponding_Spec (Prag)); + begin + pragma Assert (Postconditions_Proc (Enclosing_Scope) + = Corresponding_Spec (Prag)); + Subp_Decl := Parent (Parent (Enclosing_Scope)); + end; else Subp_Decl := Find_Related_Declaration_Or_Body (Prag); end if; @@ -2836,7 +2854,7 @@ package body Sem_Attr is if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then Error_Msg_Sloc := Sloc (P_Base_Type); Error_Msg_NE - ("comparison on unordered enumeration type& declared#?U?", + ("comparison on unordered enumeration type& declared#?.u?", N, P_Base_Type); end if; end Min_Max; @@ -9233,14 +9251,12 @@ package body Sem_Attr is -- Machine -- ------------- - -- We use the same rounding mode as the one used for RM 4.9(38) + -- We use the same rounding as the one used for RM 4.9(38/2) when Attribute_Machine => Fold_Ureal - (N, - Eval_Fat.Machine - (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round_Even, N), - Static); + (N, Machine_Number (P_Base_Type, Expr_Value_R (E1), N), Static); + Set_Is_Machine_Number (N); ------------------ -- Machine_Emax -- diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 31f14d5..1bd2670 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -106,10 +106,26 @@ package body Sem_Case is package Composite_Case_Ops is + function Box_Value_Required (Subtyp : Entity_Id) return Boolean; + -- If result is True, then the only allowed value (in a choice + -- aggregate) for a component of this (sub)type is a box. This rule + -- means that such a component can be ignored in case alternative + -- selection. This in turn implies that it is ok if the component + -- type doesn't meet the usual restrictions, such as not being an + -- access/task/protected type, since nobody is going to look + -- at it. + function Choice_Count (Alternatives : List_Id) return Nat; -- The sum of the number of choices for each alternative in the given -- list. + function Normalized_Case_Expr_Type + (Case_Statement : Node_Id) return Entity_Id; + -- Usually returns the Etype of the selector expression of the + -- case statement. However, in the case of a constrained composite + -- subtype with a nonstatic constraint, returns the unconstrained + -- base type. + function Scalar_Part_Count (Subtyp : Entity_Id) return Nat; -- Given the composite type Subtyp of a case selector, returns the -- number of scalar parts in an object of this type. This is the @@ -119,13 +135,6 @@ package body Sem_Case is function Array_Choice_Length (Choice : Node_Id) return Nat; -- Given a choice expression of an array type, returns its length. - function Normalized_Case_Expr_Type - (Case_Statement : Node_Id) return Entity_Id; - -- Usually returns the Etype of the selector expression of the - -- case statement. However, in the case of a constrained array - -- subtype with a nonstatic constraint, returns the unconstrained - -- array base type. - function Unconstrained_Array_Effective_Length (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat; -- If the nominal subtype of the case selector is unconstrained, @@ -1164,6 +1173,54 @@ package body Sem_Case is return UI_To_Int (Len); end Static_Array_Length; + ------------------------ + -- Box_Value_Required -- + ------------------------ + + function Box_Value_Required (Subtyp : Entity_Id) return Boolean is + -- Some of these restrictions will be relaxed eventually, but best + -- to initially err in the direction of being too restrictive. + begin + if Has_Predicates (Subtyp) then + return True; + elsif Is_Discrete_Type (Subtyp) then + if not Is_Static_Subtype (Subtyp) then + return True; + elsif Is_Enumeration_Type (Subtyp) + and then Has_Enumeration_Rep_Clause (Subtyp) + -- Maybe enumeration rep clauses can be ignored here? + then + return True; + end if; + elsif Is_Array_Type (Subtyp) then + if Number_Dimensions (Subtyp) /= 1 then + return True; + elsif not Is_Constrained (Subtyp) then + if not Is_Static_Subtype (Etype (First_Index (Subtyp))) then + return True; + end if; + elsif not Is_OK_Static_Range (First_Index (Subtyp)) then + return True; + end if; + elsif Is_Record_Type (Subtyp) then + if Has_Discriminants (Subtyp) + and then Is_Constrained (Subtyp) + and then not Has_Static_Discriminant_Constraint (Subtyp) + then + -- Perhaps treat differently the case where Subtyp is the + -- subtype of the top-level selector expression, as opposed + -- to the subtype of some subcomponent thereof. + return True; + end if; + else + -- Return True for any type that is not a discrete type, + -- a record type, or an array type. + return True; + end if; + + return False; + end Box_Value_Required; + ------------------ -- Choice_Count -- ------------------ @@ -1179,13 +1236,45 @@ package body Sem_Case is return Result; end Choice_Count; + ------------------------------- + -- Normalized_Case_Expr_Type -- + ------------------------------- + + function Normalized_Case_Expr_Type + (Case_Statement : Node_Id) return Entity_Id + is + Unnormalized : constant Entity_Id := + Etype (Expression (Case_Statement)); + + Is_Dynamically_Constrained_Array : constant Boolean := + Is_Array_Type (Unnormalized) + and then Is_Constrained (Unnormalized) + and then not Has_Static_Array_Bounds (Unnormalized); + + Is_Dynamically_Constrained_Record : constant Boolean := + Is_Record_Type (Unnormalized) + and then Has_Discriminants (Unnormalized) + and then Is_Constrained (Unnormalized) + and then not Has_Static_Discriminant_Constraint (Unnormalized); + begin + if Is_Dynamically_Constrained_Array + or Is_Dynamically_Constrained_Record + then + return Base_Type (Unnormalized); + else + return Unnormalized; + end if; + end Normalized_Case_Expr_Type; + ----------------------- -- Scalar_Part_Count -- ----------------------- function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is begin - if Is_Scalar_Type (Subtyp) then + if Box_Value_Required (Subtyp) then + return 0; -- component does not participate in case selection + elsif Is_Scalar_Type (Subtyp) then return 1; elsif Is_Array_Type (Subtyp) then return Static_Array_Length (Subtyp) @@ -1203,8 +1292,8 @@ package body Sem_Case is return Result; end; else - pragma Assert (False); - raise Program_Error; + pragma Assert (Serious_Errors_Detected > 0); + return 0; end if; end Scalar_Part_Count; @@ -1255,29 +1344,9 @@ package body Sem_Case is return 0; end Array_Choice_Length; - ------------------------------- - -- Normalized_Case_Expr_Type -- - ------------------------------- - - function Normalized_Case_Expr_Type - (Case_Statement : Node_Id) return Entity_Id - is - Unnormalized : constant Entity_Id := - Etype (Expression (Case_Statement)); - begin - if Is_Array_Type (Unnormalized) - and then Is_Constrained (Unnormalized) - and then not Has_Static_Array_Bounds (Unnormalized) - then - return Base_Type (Unnormalized); - else - return Unnormalized; - end if; - end Normalized_Case_Expr_Type; - - ------------------------------------------ + ------------------------------------------ -- Unconstrained_Array_Effective_Length -- - ------------------------------------------ + ------------------------------------------ function Unconstrained_Array_Effective_Length (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat @@ -1374,6 +1443,10 @@ package body Sem_Case is procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is begin + if Box_Value_Required (Subtyp) then + return; + end if; + if Is_Discrete_Type (Subtyp) then Update_Result ((Low => Expr_Value (Type_Low_Bound (Subtyp)), @@ -1668,13 +1741,32 @@ package body Sem_Case is end loop; end; - if Box_Present (Comp_Assoc) then - -- Box matches all values - Update_Result_For_Full_Coverage - (Etype (First (Choices (Comp_Assoc)))); - else - Traverse_Choice (Expression (Comp_Assoc)); - end if; + declare + Comp_Type : constant Entity_Id := + Etype (First (Choices (Comp_Assoc))); + begin + if Box_Value_Required (Comp_Type) then + -- This component is not allowed to + -- influence which alternative is + -- chosen; case choice must be box. + -- + -- For example, component might be + -- of a real type or of an access type + -- or of a non-static discrete subtype. + if not Box_Present (Comp_Assoc) then + Error_Msg_N + ("Non-box case choice component value" & + " of unsupported type/subtype", + Expression (Comp_Assoc)); + end if; + elsif Box_Present (Comp_Assoc) then + -- Box matches all values + Update_Result_For_Full_Coverage + (Etype (First (Choices (Comp_Assoc)))); + else + Traverse_Choice (Expression (Comp_Assoc)); + end if; + end; if Binding_Chars (Comp_Assoc) /= No_Name then @@ -1702,9 +1794,19 @@ package body Sem_Case is Next_Component_Or_Discriminant (Comp_From_Type); end loop; - pragma Assert - (Nat (Next_Part - Saved_Next_Part) - = Scalar_Part_Count (Etype (Expr))); + declare + Expr_Type : Entity_Id := Etype (Expr); + begin + if Has_Discriminants (Expr_Type) then + -- Avoid nonstatic choice expr types, + -- for which Scalar_Part_Count returns 0. + Expr_Type := Base_Type (Expr_Type); + end if; + + pragma Assert + (Nat (Next_Part - Saved_Next_Part) + = Scalar_Part_Count (Expr_Type)); + end; end; elsif Is_Array_Type (Etype (Expr)) then if Is_Non_Empty_List (Component_Associations (Expr)) then @@ -3256,108 +3358,14 @@ package body Sem_Case is ----------------------------------- procedure Check_Composite_Case_Selector is - -- Some of these restrictions will be relaxed eventually, but best - -- to initially err in the direction of being too restrictive. - - procedure Check_Component_Subtype (Subtyp : Entity_Id); - -- Recursively traverse subcomponent types to perform checks. - - ----------------------------- - -- Check_Component_Subtype -- - ----------------------------- - - procedure Check_Component_Subtype (Subtyp : Entity_Id) is - begin - if Has_Predicates (Subtyp) then - Error_Msg_N - ("subtype of case selector (or subcomponent thereof) " & - "has predicate", N); - elsif Is_Discrete_Type (Subtyp) then - if not Is_Static_Subtype (Subtyp) then - Error_Msg_N - ("discrete subtype of selector subcomponent is not " & - "a static subtype", N); - elsif Is_Enumeration_Type (Subtyp) - and then Has_Enumeration_Rep_Clause (Subtyp) - then - Error_Msg_N - ("enumeration type of selector subcomponent has " & - "an enumeration representation clause", N); - end if; - elsif Is_Array_Type (Subtyp) then - if Number_Dimensions (Subtyp) /= 1 then - Error_Msg_N - ("dimensionality of array type of case selector (or " & - "subcomponent thereof) is greater than 1", N); - - elsif not Is_Constrained (Subtyp) then - if not Is_Static_Subtype - (Etype (First_Index (Subtyp))) - then - Error_Msg_N - ("Unconstrained array subtype of case selector" & - " has nonstatic index subtype", N); - end if; - - elsif not Is_OK_Static_Range (First_Index (Subtyp)) then - Error_Msg_N - ("array subtype of case selector (or " & - "subcomponent thereof) has nonstatic constraint", N); - end if; - Check_Component_Subtype (Component_Type (Subtyp)); - elsif Is_Record_Type (Subtyp) then - - if Has_Discriminants (Subtyp) - and then Is_Constrained (Subtyp) - and then not Has_Static_Discriminant_Constraint (Subtyp) - then - -- We are only disallowing nonstatic constraints for - -- subcomponent subtypes, not for the subtype of the - -- expression we are casing on. This test could be - -- implemented via an Is_Recursive_Call parameter if - -- that seems preferable. - - if Subtyp /= Check_Choices.Subtyp then - Error_Msg_N - ("constrained discriminated subtype of case " & - "selector subcomponent has nonstatic " & - "constraint", N); - end if; - end if; - - declare - Comp : Entity_Id := - First_Component_Or_Discriminant (Base_Type (Subtyp)); - begin - while Present (Comp) loop - Check_Component_Subtype (Etype (Comp)); - Next_Component_Or_Discriminant (Comp); - end loop; - end; - else - Error_Msg_N - ("type of case selector (or subcomponent thereof) is " & - "not a discrete type, a record type, or an array type", - N); - end if; - end Check_Component_Subtype; - begin if not Is_Composite_Type (Subtyp) then Error_Msg_N ("case selector type neither discrete nor composite", N); - elsif Is_Limited_Type (Subtyp) then Error_Msg_N ("case selector type is limited", N); - elsif Is_Class_Wide_Type (Subtyp) then Error_Msg_N ("case selector type is class-wide", N); - - elsif Needs_Finalization (Subtyp) then - Error_Msg_N ("case selector type requires finalization", N); - - else - Check_Component_Subtype (Subtyp); end if; end Check_Composite_Case_Selector; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index dd78501..6305bdb 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -341,8 +341,8 @@ package body Sem_Ch10 is function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is begin return Entity (N) = P - or else (Present (Renamed_Object (P)) - and then Entity (N) = Renamed_Object (P)); + or else (Present (Renamed_Entity (P)) + and then Entity (N) = Renamed_Entity (P)); end Same_Unit; -- Start of processing for Process_Body_Clauses @@ -1102,14 +1102,14 @@ package body Sem_Ch10 is then Style_Check := False; - if Present (Renamed_Object (Nam)) then + if Present (Renamed_Entity (Nam)) then Un := Load_Unit (Load_Name => Get_Body_Name (Get_Unit_Name (Unit_Declaration_Node - (Renamed_Object (Nam)))), + (Renamed_Entity (Nam)))), Required => False, Subunit => False, Error_Node => N, @@ -2870,7 +2870,7 @@ package body Sem_Ch10 is -- been analyzed. Analyze (Parent (Parent (Entity (Pref)))); - pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name); + pragma Assert (Renamed_Entity (Entity (Pref)) = Par_Name); Par_Name := Entity (Pref); end if; @@ -4162,8 +4162,7 @@ package body Sem_Ch10 is end if; if Ekind (P_Name) = E_Generic_Package - and then Nkind (Lib_Unit) not in N_Generic_Subprogram_Declaration - | N_Generic_Package_Declaration + and then Nkind (Lib_Unit) not in N_Generic_Declaration | N_Generic_Renaming_Declaration then Error_Msg_N @@ -4174,7 +4173,7 @@ package body Sem_Ch10 is ("parent unit must be package or generic package", Lib_Unit); raise Unrecoverable_Error; - elsif Present (Renamed_Object (P_Name)) then + elsif Present (Renamed_Entity (P_Name)) then Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); raise Unrecoverable_Error; @@ -5610,9 +5609,8 @@ package body Sem_Ch10 is -- demand, at the point of instantiation (see ch12). procedure Load_Needed_Body - (N : Node_Id; - OK : out Boolean; - Do_Analyze : Boolean := True) + (N : Node_Id; + OK : out Boolean) is Body_Name : Unit_Name_Type; Unum : Unit_Number_Type; @@ -5646,9 +5644,8 @@ package body Sem_Ch10 is Write_Eol; end if; - if Do_Analyze then - Semantics (Cunit (Unum)); - end if; + -- We always perform analyses + Semantics (Cunit (Unum)); end if; OK := True; @@ -6195,9 +6192,7 @@ package body Sem_Ch10 is ("subprogram not allowed in `LIMITED WITH` clause", N); return; - when N_Generic_Package_Declaration - | N_Generic_Subprogram_Declaration - => + when N_Generic_Declaration => Error_Msg_N ("generic not allowed in `LIMITED WITH` clause", N); return; diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index fbaf3ca..ecf3151a5 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -59,16 +59,13 @@ package Sem_Ch10 is -- reported on Error_Node (if present); otherwise no error is reported. procedure Load_Needed_Body - (N : Node_Id; - OK : out Boolean; - Do_Analyze : Boolean := True); + (N : Node_Id; + OK : out Boolean); -- Load and analyze the body of a context unit that is generic, or that -- contains generic units or inlined units. The body becomes part of the -- semantic dependency set of the unit that needs it. The returned result -- in OK is True if the load is successful, and False if the requested file - -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and - -- parsed only. This allows a selective analysis in some inlining cases - -- where a full analysis would lead so circularities in the back-end. + -- cannot be found. procedure Remove_Context (N : Node_Id); -- Removes the entities from the context clause of the given compilation diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e4cb7e3..d46d65c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2935,7 +2935,7 @@ package body Sem_Ch12 is -- Check for a formal package that is a package renaming - if Present (Renamed_Object (Gen_Unit)) then + if Present (Renamed_Entity (Gen_Unit)) then -- Indicate that unit is used, before replacing it with renamed -- entity for use below. @@ -2945,7 +2945,7 @@ package body Sem_Ch12 is Generate_Reference (Gen_Unit, N); end if; - Gen_Unit := Renamed_Object (Gen_Unit); + Gen_Unit := Renamed_Entity (Gen_Unit); end if; if Ekind (Gen_Unit) /= E_Generic_Package then @@ -3117,7 +3117,7 @@ package body Sem_Ch12 is Set_Etype (Renaming_In_Par, Standard_Void_Type); Set_Scope (Renaming_In_Par, Parent_Instance); Set_Parent (Renaming_In_Par, Parent (Formal)); - Set_Renamed_Object (Renaming_In_Par, Formal); + Set_Renamed_Entity (Renaming_In_Par, Formal); Append_Entity (Renaming_In_Par, Parent_Instance); end if; @@ -4287,9 +4287,9 @@ package body Sem_Ch12 is Set_Is_Instantiated (Gen_Unit); Generate_Reference (Gen_Unit, N); - if Present (Renamed_Object (Gen_Unit)) then - Set_Is_Instantiated (Renamed_Object (Gen_Unit)); - Generate_Reference (Renamed_Object (Gen_Unit), N); + if Present (Renamed_Entity (Gen_Unit)) then + Set_Is_Instantiated (Renamed_Entity (Gen_Unit)); + Generate_Reference (Renamed_Entity (Gen_Unit), N); end if; end if; @@ -4312,10 +4312,10 @@ package body Sem_Ch12 is -- If generic is a renaming, get original generic unit - if Present (Renamed_Object (Gen_Unit)) - and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package + if Present (Renamed_Entity (Gen_Unit)) + and then Ekind (Renamed_Entity (Gen_Unit)) = E_Generic_Package then - Gen_Unit := Renamed_Object (Gen_Unit); + Gen_Unit := Renamed_Entity (Gen_Unit); end if; -- Verify that there are no circular instantiations @@ -5692,10 +5692,10 @@ package body Sem_Ch12 is -- If renaming, get original unit - if Present (Renamed_Object (Gen_Unit)) - and then Is_Generic_Subprogram (Renamed_Object (Gen_Unit)) + if Present (Renamed_Entity (Gen_Unit)) + and then Is_Generic_Subprogram (Renamed_Entity (Gen_Unit)) then - Gen_Unit := Renamed_Object (Gen_Unit); + Gen_Unit := Renamed_Entity (Gen_Unit); Set_Is_Instantiated (Gen_Unit); Generate_Reference (Gen_Unit, N); end if; @@ -5802,6 +5802,7 @@ package body Sem_Ch12 is if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Anon_Id); + Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); end if; Analyze_Instance_And_Renamings; @@ -5818,14 +5819,13 @@ package body Sem_Ch12 is end if; -- If the generic is marked Import (Intrinsic), then so is the - -- instance. This indicates that there is no body to instantiate. If - -- generic is marked inline, so it the instance, and the anonymous - -- subprogram it renames. If inlined, or else if inlining is enabled - -- for the compilation, we generate the instance body even if it is - -- not within the main unit. + -- instance; this indicates that there is no body to instantiate. + -- We also copy the interface name in case this is handled by the + -- back-end and deal with an instance of unchecked conversion. if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Act_Decl_Id); + Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); if Chars (Gen_Unit) = Name_Unchecked_Conversion then Validate_Unchecked_Conversion (N, Act_Decl_Id); @@ -6856,9 +6856,9 @@ package body Sem_Ch12 is elsif Ekind (E1) = E_Package then Check_Mismatch (Ekind (E1) /= Ekind (E2) - or else (Present (Renamed_Object (E2)) - and then Renamed_Object (E1) /= - Renamed_Object (E2))); + or else (Present (Renamed_Entity (E2)) + and then Renamed_Entity (E1) /= + Renamed_Entity (E2))); elsif Is_Overloadable (E1) then -- Verify that the actual subprograms match. Note that actuals @@ -6929,7 +6929,7 @@ package body Sem_Ch12 is E := First_Entity (P_Id); while Present (E) loop if Ekind (E) = E_Package then - if Renamed_Object (E) = P_Id then + if Renamed_Entity (E) = P_Id then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then @@ -7128,7 +7128,7 @@ package body Sem_Ch12 is -- formal part are also visible. Otherwise, ignore the entity -- created to validate the actuals. - if Renamed_Object (E) = Instance then + if Renamed_Entity (E) = Instance then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then @@ -7144,10 +7144,10 @@ package body Sem_Ch12 is and then not Is_Generic_Formal (E) then if Box_Present (Parent (Associated_Formal_Package (E))) then - Check_Generic_Actuals (Renamed_Object (E), True); + Check_Generic_Actuals (Renamed_Entity (E), True); else - Check_Generic_Actuals (Renamed_Object (E), False); + Check_Generic_Actuals (Renamed_Entity (E), False); end if; Set_Is_Hidden (E, False); @@ -7380,9 +7380,9 @@ package body Sem_Ch12 is Inst_Par := Entity (Prefix (Gen_Id)); if Ekind (Inst_Par) = E_Package - and then Present (Renamed_Object (Inst_Par)) + and then Present (Renamed_Entity (Inst_Par)) then - Inst_Par := Renamed_Object (Inst_Par); + Inst_Par := Renamed_Entity (Inst_Par); end if; if Ekind (Inst_Par) = E_Package then @@ -7584,7 +7584,8 @@ package body Sem_Ch12 is E := First_Entity (Entity (Prefix (Gen_Id))); while Present (E) loop - if Present (Renamed_Entity (E)) + if not Is_Object (E) + and then Present (Renamed_Entity (E)) and then Renamed_Entity (E) = Renamed_Entity (Entity (Gen_Id)) then @@ -7621,8 +7622,8 @@ package body Sem_Ch12 is if Is_Generic_Unit (E) and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration - and then Is_Child_Unit (Renamed_Object (E)) - and then Is_Generic_Unit (Scope (Renamed_Object (E))) + and then Is_Child_Unit (Renamed_Entity (E)) + and then Is_Generic_Unit (Scope (Renamed_Entity (E))) and then Nkind (Name (Parent (E))) = N_Expanded_Name then Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E)))); @@ -8090,7 +8091,9 @@ package body Sem_Ch12 is (Scope (Ent) = Current_Instantiated_Parent.Gen_Id and then not Is_Child_Unit (Ent)) or else - (Scope_Depth (Scope (Ent)) > + (Scope_Depth_Set (Scope (Ent)) + and then + Scope_Depth (Scope (Ent)) > Scope_Depth (Current_Instantiated_Parent.Gen_Id) and then Get_Source_Unit (Ent) = @@ -8689,10 +8692,10 @@ package body Sem_Ch12 is if Ekind (E1) = E_Package and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration then - if Renamed_Object (E1) = Pack then + if Renamed_Entity (E1) = Pack then return True; - elsif E1 = P or else Renamed_Object (E1) = P then + elsif E1 = P or else Renamed_Entity (E1) = P then return False; elsif Is_Actual_Of_Previous_Formal (E1) then @@ -8742,10 +8745,10 @@ package body Sem_Ch12 is then null; - elsif Renamed_Object (E) = Par then + elsif Renamed_Entity (E) = Par then return False; - elsif Renamed_Object (E) = Pack then + elsif Renamed_Entity (E) = Pack then return True; elsif Is_Actual_Of_Previous_Formal (E) then @@ -10077,7 +10080,7 @@ package body Sem_Ch12 is then -- If this is the renaming for the parent instance, done - if Renamed_Object (E) = Par then + if Renamed_Entity (E) = Par then exit; -- The visibility of a formal of an enclosing generic is already @@ -10087,7 +10090,7 @@ package body Sem_Ch12 is null; elsif Present (Associated_Formal_Package (E)) then - Check_Generic_Actuals (Renamed_Object (E), True); + Check_Generic_Actuals (Renamed_Entity (E), True); Set_Is_Hidden (E, False); -- Find formal package in generic unit that corresponds to @@ -10697,8 +10700,8 @@ package body Sem_Ch12 is -- The actual may be a renamed package, or an outer generic formal -- package whose instantiation is converted into a renaming. - if Present (Renamed_Object (Actual_Pack)) then - Actual_Pack := Renamed_Object (Actual_Pack); + if Present (Renamed_Entity (Actual_Pack)) then + Actual_Pack := Renamed_Entity (Actual_Pack); end if; if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then @@ -11796,7 +11799,7 @@ package body Sem_Ch12 is while Present (Actual) loop exit when Ekind (Actual) = E_Package - and then Present (Renamed_Object (Actual)); + and then Present (Renamed_Entity (Actual)); if Chars (Actual) = Chars (Formal) and then not Is_Scalar_Type (Actual) @@ -14789,7 +14792,7 @@ package body Sem_Ch12 is Set_Instance_Of (Base_Type (E1), Base_Type (E2)); end if; - if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then + if Ekind (E1) = E_Package and then No (Renamed_Entity (E1)) then Map_Formal_Package_Entities (E1, E2); end if; end if; @@ -15345,11 +15348,11 @@ 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_Object (Formal)) - and then Denotes_Formal_Package (Renamed_Object (Formal), True) + if Present (Renamed_Entity (Formal)) + and then Denotes_Formal_Package (Renamed_Entity (Formal), True) then return; @@ -15488,20 +15491,20 @@ package body Sem_Ch12 is -- visible on exit from the instance, and therefore nothing needs -- to be done either, except to keep it accessible. - if Is_Package and then Renamed_Object (E) = Pack_Id then + if Is_Package and then Renamed_Entity (E) = Pack_Id then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then null; elsif - Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) + Denotes_Formal_Package (Renamed_Entity (E), True, Pack_Id) then Set_Is_Hidden (E, False); else declare - Act_P : constant Entity_Id := Renamed_Object (E); + Act_P : constant Entity_Id := Renamed_Entity (E); Id : Entity_Id; begin @@ -15510,7 +15513,7 @@ package body Sem_Ch12 is and then Id /= First_Private_Entity (Act_P) loop exit when Ekind (Id) = E_Package - and then Renamed_Object (Id) = Act_P; + and then Renamed_Entity (Id) = Act_P; Set_Is_Hidden (Id, True); Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fb1be47..6059cee 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -483,16 +483,16 @@ package body Sem_Ch13 is if Warn_On_Reverse_Bit_Order then Error_Msg_N ("info: multi-byte field specified with " - & "non-standard Bit_Order?V?", CC); + & "non-standard Bit_Order?.v?", CC); if Bytes_Big_Endian then Error_Msg_N ("\bytes are not reversed " - & "(component is big-endian)?V?", CC); + & "(component is big-endian)?.v?", CC); else Error_Msg_N ("\bytes are not reversed " - & "(component is little-endian)?V?", CC); + & "(component is little-endian)?.v?", CC); end if; end if; @@ -707,17 +707,18 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := MSS; Error_Msg_N ("info: reverse bit order in machine scalar of " - & "length^?V?", First_Bit (CC)); + & "length^?.v?", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE - ("\big-endian range for component & is ^ .. ^?V?", + ("\big-endian range for component & is ^ .. ^?.v?", First_Bit (CC), Comp); else Error_Msg_NE - ("\little-endian range for component & is ^ .. ^?V?", + ("\little-endian range for component " & + "& is ^ .. ^?.v?", First_Bit (CC), Comp); end if; end if; @@ -782,16 +783,16 @@ package body Sem_Ch13 is then Error_Msg_N ("info: multi-byte field specified with non-standard " - & "Bit_Order?V?", CLC); + & "Bit_Order?.v?", CLC); if Bytes_Big_Endian then Error_Msg_N ("\bytes are not reversed " - & "(component is big-endian)?V?", CLC); + & "(component is big-endian)?.v?", CLC); else Error_Msg_N ("\bytes are not reversed " - & "(component is little-endian)?V?", CLC); + & "(component is little-endian)?.v?", CLC); end if; -- Do not allow non-contiguous field @@ -815,13 +816,13 @@ package body Sem_Ch13 is then Error_Msg_N ("info: Bit_Order clause does not affect byte " - & "ordering?V?", Pos); + & "ordering?.v?", Pos); Error_Msg_Uint_1 := Intval (Pos) + Intval (FB) / System_Storage_Unit; Error_Msg_N ("info: position normalized to ^ before bit order " - & "interpreted?V?", Pos); + & "interpreted?.v?", Pos); end if; -- Here is where we fix up the Component_Bit_Offset value @@ -6911,7 +6912,7 @@ package body Sem_Ch13 is and then RM_Size (Ctyp) /= Csize then Error_Msg_NE - ("component size overrides size clause for&?S?", N, Ctyp); + ("component size overrides size clause for&?.s?", N, Ctyp); end if; Set_Has_Component_Size_Clause (Btype, True); @@ -7960,7 +7961,7 @@ package body Sem_Ch13 is ("stream size for elementary type must be 8, 16, 24, " & "32 or 64", N); - elsif RM_Size (U_Ent) > Size then + elsif Known_RM_Size (U_Ent) and then RM_Size (U_Ent) > Size then Error_Msg_Uint_1 := RM_Size (U_Ent); Error_Msg_N ("stream size for elementary type must be 8, 16, 24, " & @@ -8809,7 +8810,7 @@ package body Sem_Ch13 is and then RM_Size (Etype (Comp)) /= Esize (Comp) then Error_Msg_NE - ("?S?component size overrides size clause for&", + ("?.s?component size overrides size clause for&", Component_Name (CC), Etype (Comp)); end if; @@ -8918,7 +8919,7 @@ package body Sem_Ch13 is then Error_Msg_Sloc := Sloc (Comp); Error_Msg_NE - ("?C?no component clause given for & declared #", + ("?.c?no component clause given for & declared #", N, Comp); end if; @@ -8940,9 +8941,6 @@ package body Sem_Ch13 is is Loc : constant Source_Ptr := Sloc (Expr); - Non_Static : exception; - -- Raised if something non-static is found - Btyp : constant Entity_Id := Base_Type (Typ); BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); @@ -8995,7 +8993,7 @@ package body Sem_Ch13 is function Build_Val (V : Uint) return Node_Id; -- Return an analyzed N_Identifier node referencing this value, suitable - -- for use as an entry in the Static_Discrte_Predicate list. This node + -- for use as an entry in the Static_Discrete_Predicate list. This node -- is typed with the base type. function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; @@ -9003,9 +9001,13 @@ package body Sem_Ch13 is -- use as an entry in the Static_Discrete_Predicate list. This node is -- typed with the base type. - function Get_RList (Exp : Node_Id) return RList; + function Get_RList + (Exp : Node_Id; + Static : access Boolean) return RList; -- This is a recursive routine that converts the given expression into a -- list of ranges, suitable for use in building the static predicate. + -- Static.all will be set to False if the expression is found to be non + -- static. Note that Static.all should be set to True by the caller. function Is_False (R : RList) return Boolean; pragma Inline (Is_False); @@ -9033,18 +9035,23 @@ package body Sem_Ch13 is -- a static expression or static range, gets either the expression value -- or the high bound of the range. - function Membership_Entry (N : Node_Id) return RList; + function Membership_Entry + (N : Node_Id; Static : access Boolean) return RList; -- Given a single membership entry (range, value, or subtype), returns - -- the corresponding range list. Raises Static_Error if not static. + -- the corresponding range list. Set Static.all to False if not static. - function Membership_Entries (N : Node_Id) return RList; + function Membership_Entries + (N : Node_Id; Static : access Boolean) return RList; -- Given an element on an alternatives list of a membership operation, -- returns the range list corresponding to this entry and all following -- entries (i.e. returns the "or" of this list of values). + -- Set Static.all to False if not static. - function Stat_Pred (Typ : Entity_Id) return RList; - -- Given a type, if it has a static predicate, then return the predicate - -- as a range list, otherwise raise Non_Static. + function Stat_Pred + (Typ : Entity_Id; + Static : access Boolean) return RList; + -- Given a type, if it has a static predicate, then set Result to the + -- predicate as a range list, otherwise set Static.all to False. ----------- -- "and" -- @@ -9296,7 +9303,10 @@ package body Sem_Ch13 is -- Get_RList -- --------------- - function Get_RList (Exp : Node_Id) return RList is + function Get_RList + (Exp : Node_Id; + Static : access Boolean) return RList + is Op : Node_Kind; Val : Uint; @@ -9322,23 +9332,23 @@ package body Sem_Ch13 is when N_And_Then | N_Op_And => - return Get_RList (Left_Opnd (Exp)) + return Get_RList (Left_Opnd (Exp), Static) and - Get_RList (Right_Opnd (Exp)); + Get_RList (Right_Opnd (Exp), Static); -- Or when N_Op_Or | N_Or_Else => - return Get_RList (Left_Opnd (Exp)) + return Get_RList (Left_Opnd (Exp), Static) or - Get_RList (Right_Opnd (Exp)); + Get_RList (Right_Opnd (Exp), Static); -- Not when N_Op_Not => - return not Get_RList (Right_Opnd (Exp)); + return not Get_RList (Right_Opnd (Exp), Static); -- Comparisons of type with static value @@ -9371,7 +9381,8 @@ package body Sem_Ch13 is -- Other cases are non-static else - raise Non_Static; + Static.all := False; + return False_Range; end if; -- Construct range according to comparison operation @@ -9403,26 +9414,30 @@ package body Sem_Ch13 is when N_In => if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; + Static.all := False; + return False_Range; end if; if Present (Right_Opnd (Exp)) then - return Membership_Entry (Right_Opnd (Exp)); + return Membership_Entry (Right_Opnd (Exp), Static); else - return Membership_Entries (First (Alternatives (Exp))); + return Membership_Entries + (First (Alternatives (Exp)), Static); end if; -- Negative membership (NOT IN) when N_Not_In => if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; + Static.all := False; + return False_Range; end if; if Present (Right_Opnd (Exp)) then - return not Membership_Entry (Right_Opnd (Exp)); + return not Membership_Entry (Right_Opnd (Exp), Static); else - return not Membership_Entries (First (Alternatives (Exp))); + return not Membership_Entries + (First (Alternatives (Exp)), Static); end if; -- Function call, may be call to static predicate @@ -9436,19 +9451,20 @@ package body Sem_Ch13 is or else Is_Predicate_Function_M (Ent) then - return Stat_Pred (Etype (First_Formal (Ent))); + return Stat_Pred (Etype (First_Formal (Ent)), Static); end if; end; end if; -- Other function call cases are non-static - raise Non_Static; + Static.all := False; + return False_Range; -- Qualified expression, dig out the expression when N_Qualified_Expression => - return Get_RList (Expression (Exp)); + return Get_RList (Expression (Exp), Static); when N_Case_Expression => declare @@ -9473,7 +9489,8 @@ package body Sem_Ch13 is Dep := Expression (Alt); if not Is_OK_Static_Expression (Dep) then - raise Non_Static; + Static.all := False; + return False_Range; elsif Is_True (Expr_Value (Dep)) then Append_List_To (Choices, @@ -9483,30 +9500,32 @@ package body Sem_Ch13 is Next (Alt); end loop; - return Membership_Entries (First (Choices)); + return Membership_Entries (First (Choices), Static); end; -- Expression with actions: if no actions, dig out expression when N_Expression_With_Actions => if Is_Empty_List (Actions (Exp)) then - return Get_RList (Expression (Exp)); + return Get_RList (Expression (Exp), Static); else - raise Non_Static; + Static.all := False; + return False_Range; end if; -- Xor operator when N_Op_Xor => - return (Get_RList (Left_Opnd (Exp)) - and not Get_RList (Right_Opnd (Exp))) - or (Get_RList (Right_Opnd (Exp)) - and not Get_RList (Left_Opnd (Exp))); + return (Get_RList (Left_Opnd (Exp), Static) + and not Get_RList (Right_Opnd (Exp), Static)) + or (Get_RList (Right_Opnd (Exp), Static) + and not Get_RList (Left_Opnd (Exp), Static)); -- Any other node type is non-static when others => - raise Non_Static; + Static.all := False; + return False_Range; end case; end Get_RList; @@ -9573,12 +9592,14 @@ package body Sem_Ch13 is -- Membership_Entries -- ------------------------ - function Membership_Entries (N : Node_Id) return RList is + function Membership_Entries + (N : Node_Id; Static : access Boolean) return RList is begin if No (Next (N)) then - return Membership_Entry (N); + return Membership_Entry (N, Static); else - return Membership_Entry (N) or Membership_Entries (Next (N)); + return Membership_Entry (N, Static) + or Membership_Entries (Next (N), Static); end if; end Membership_Entries; @@ -9586,7 +9607,9 @@ package body Sem_Ch13 is -- Membership_Entry -- ---------------------- - function Membership_Entry (N : Node_Id) return RList is + function Membership_Entry + (N : Node_Id; Static : access Boolean) return RList + is Val : Uint; SLo : Uint; SHi : Uint; @@ -9599,7 +9622,8 @@ package body Sem_Ch13 is or else not Is_OK_Static_Expression (High_Bound (N)) then - raise Non_Static; + Static.all := False; + return False_Range; else SLo := Expr_Value (Low_Bound (N)); SHi := Expr_Value (High_Bound (N)); @@ -9642,7 +9666,7 @@ package body Sem_Ch13 is -- If type has predicates, process them if Has_Predicates (Entity (N)) then - return Stat_Pred (Entity (N)); + return Stat_Pred (Entity (N), Static); -- For static subtype without predicates, get range @@ -9654,14 +9678,16 @@ package body Sem_Ch13 is -- Any other type makes us non-static else - raise Non_Static; + Static.all := False; + return False_Range; end if; -- Any other kind of identifier in predicate (e.g. a non-static -- expression value) means this is not a static predicate. else - raise Non_Static; + Static.all := False; + return False_Range; end if; end if; end Membership_Entry; @@ -9670,12 +9696,15 @@ package body Sem_Ch13 is -- Stat_Pred -- --------------- - function Stat_Pred (Typ : Entity_Id) return RList is + function Stat_Pred + (Typ : Entity_Id; + Static : access Boolean) return RList is begin -- Not static if type does not have static predicates if not Has_Static_Predicate (Typ) then - raise Non_Static; + Static.all := False; + return False_Range; end if; -- Otherwise we convert the predicate list to a range list @@ -9716,12 +9745,19 @@ package body Sem_Ch13 is -- Analyze the expression to see if it is a static predicate declare - Ranges : constant RList := Get_RList (Expr); + Static : aliased Boolean := True; + Ranges : constant RList := Get_RList (Expr, Static'Access); -- Range list from expression if it is static Plist : List_Id; begin + -- If non-static, return doing nothing + + if not Static then + return; + end if; + -- Convert range list into a form for the static predicate. In the -- Ranges array, we just have raw ranges, these must be converted -- to properly typed and analyzed static expressions or range nodes. @@ -9826,12 +9862,6 @@ package body Sem_Ch13 is end if; end; end; - - -- If non-static, return doing nothing - - exception - when Non_Static => - return; end Build_Discrete_Static_Predicate; -------------------------------- @@ -10096,7 +10126,7 @@ package body Sem_Ch13 is then Error_Msg_Sloc := Sloc (Predicate_Function (T)); Error_Msg_Node_2 := T; - Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); + Error_Msg_N ("info: & inherits predicate from & #?.l?", Typ); end if; end if; end Add_Call; @@ -11881,7 +11911,7 @@ package body Sem_Ch13 is Clause : Node_Id := First (Component_Clauses (N)); Prev_Bit_Offset : Uint := Uint_0; OOO : constant String := - "?component clause out of order with respect to declaration"; + "?_r?component clause out of order with respect to declaration"; begin -- Step Comp through components and Clause through component clauses, @@ -11907,7 +11937,7 @@ package body Sem_Ch13 is and then not Reverse_Storage_Order (Rectype) and then Component_Bit_Offset (Comp) < Prev_Bit_Offset then - Error_Msg_N ("?memory layout out of order", Clause); + Error_Msg_N ("?_r?memory layout out of order", Clause); exit; end if; @@ -12147,7 +12177,7 @@ package body Sem_Ch13 is if Warn and then Error_Msg_Uint_1 > 0 then Error_Msg_NE - ("?H?^-bit gap before component&", + ("?.h?^-bit gap before component&", Component_Name (Component_Clause (CEnt)), CEnt); end if; @@ -13144,6 +13174,28 @@ package body Sem_Ch13 is else Check_Aspect_At_Freeze_Point (Ritem); end if; + + -- A pragma Predicate should be checked like one of the + -- corresponding aspects, wrt possible misuse of ghost + -- entities. + + elsif Nkind (Ritem) = N_Pragma + and then No (Corresponding_Aspect (Ritem)) + and then + Get_Pragma_Id (Pragma_Name (Ritem)) = Pragma_Predicate + then + -- Retrieve the visibility to components and discriminants + -- in order to properly analyze the pragma. + + declare + Arg : constant Node_Id := + Next (First (Pragma_Argument_Associations (Ritem))); + begin + Push_Type (E); + Preanalyze_Spec_Expression + (Expression (Arg), Standard_Boolean); + Pop_Type (E); + end; end if; Next_Rep_Item (Ritem); @@ -16649,7 +16701,7 @@ package body Sem_Ch13 is if Warn_On_Biased_Representation then Error_Msg_NE - ("?B?" & Msg & " forces biased representation for&", N, E); + ("?.b?" & Msg & " forces biased representation for&", N, E); end if; end if; end Set_Biased; @@ -17335,8 +17387,32 @@ package body Sem_Ch13 is is Source : Entity_Id; Target : Entity_Id; + + procedure Warn_Nonportable (RE : RE_Id); + -- Warn if either source or target of the conversion is a predefined + -- private type, whose representation might differ between releases and + -- targets of the compiler. + + ---------------------- + -- Warn_Nonportable -- + ---------------------- + + procedure Warn_Nonportable (RE : RE_Id) is + begin + if Is_RTE (Source, RE) or else Is_RTE (Target, RE) then + pragma Assert (Is_Private_Type (RTE (RE))); + Error_Msg_NE + ("?z?representation of & values may change between " + & "'G'N'A'T versions", N, RTE (RE)); + end if; + end Warn_Nonportable; + + -- Local variables + Vnode : Node_Id; + -- Start of processing for Validate_Unchecked_Conversion + begin -- Obtain source and target types. Note that we call Ancestor_Subtype -- here because the processing for generic instantiation always makes @@ -17353,6 +17429,18 @@ package body Sem_Ch13 is return; end if; + -- Warn if one of the operands is a private type declared in + -- Ada.Calendar or Ada.Real_Time. Do not emit a warning when compiling + -- GNAT-related sources. + + if Warn_On_Unchecked_Conversion + and then not In_Predefined_Unit (N) + then + Warn_Nonportable (RO_CA_Time); + Warn_Nonportable (RO_RT_Time); + Warn_Nonportable (RE_Time_Span); + end if; + -- If we are dealing with private types, then do the check on their -- fully declared counterparts if the full declarations have been -- encountered (they don't have to be visible, but they must exist). @@ -17399,32 +17487,6 @@ package body Sem_Ch13 is end if; end if; - -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a - -- warning when compiling GNAT-related sources. - - if Warn_On_Unchecked_Conversion - and then not In_Predefined_Unit (N) - and then RTU_Loaded (Ada_Calendar) - and then (Chars (Source) = Name_Time - or else - Chars (Target) = Name_Time) - then - -- If Ada.Calendar is loaded and the name of one of the operands is - -- Time, there is a good chance that this is Ada.Calendar.Time. - - declare - Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time)); - begin - pragma Assert (Present (Calendar_Time)); - - if Source = Calendar_Time or else Target = Calendar_Time then - Error_Msg_N - ("?z?representation of 'Time values may change between " - & "'G'N'A'T versions", N); - end if; - end; - end if; - -- Make entry in unchecked conversion table for later processing by -- Validate_Unchecked_Conversions, which will check sizes and alignments -- (using values set by the back end where possible). This is only done @@ -17559,7 +17621,9 @@ package body Sem_Ch13 is Source_Siz := RM_Size (Source); Target_Siz := RM_Size (Target); - if Source_Siz /= Target_Siz then + if Present (Source_Siz) and then Present (Target_Siz) + and then Source_Siz /= Target_Siz + then Error_Msg ("?z?types for unchecked conversion have different sizes!", Eloc, Act_Unit); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f1a56ad..152ef83 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6343,7 +6343,7 @@ package body Sem_Ch3 is -- Complete setup of implicit base type - Set_Component_Size (Implicit_Base, Uint_0); + pragma Assert (not Known_Component_Size (Implicit_Base)); Set_Component_Type (Implicit_Base, Element_Type); Set_Finalize_Storage_Only (Implicit_Base, @@ -6372,7 +6372,7 @@ package body Sem_Ch3 is Reinit_Size_Align (T); Set_Etype (T, T); Set_Scope (T, Current_Scope); - Set_Component_Size (T, Uint_0); + pragma Assert (not Known_Component_Size (T)); Set_Is_Constrained (T, False); Set_Is_Fixed_Lower_Bound_Array_Subtype (T, Has_FLB_Index); @@ -17585,7 +17585,7 @@ package body Sem_Ch3 is Set_High_Bound (R_Node, B_Node); -- Initialize various fields of the type. Some of this information - -- may be overwritten later through rep.clauses. + -- may be overwritten later through rep. clauses. Set_Scalar_Range (T, R_Node); Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); @@ -18517,7 +18517,12 @@ package body Sem_Ch3 is 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); + + if Digs_Val >= Uint_1 then + Set_Digits_Value (T, Digs_Val); + else + pragma Assert (Serious_Errors_Detected > 0); null; + end if; end Floating_Point_Type_Declaration; ---------------------------- @@ -19641,8 +19646,8 @@ package body Sem_Ch3 is return; end if; - -- If the range bounds are "T'Low .. T'High" where T is a name of - -- a discrete type, then use T as the type of the index. + -- If the range bounds are "T'First .. T'Last" where T is a name of a + -- discrete type, then use T as the type of the index. if Nkind (Low_Bound (N)) = N_Attribute_Reference and then Attribute_Name (Low_Bound (N)) = Name_First @@ -19885,7 +19890,7 @@ package body Sem_Ch3 is and then Intval (Right_Opnd (Mod_Expr)) <= Uint_128 then Error_Msg_N - ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); + ("suspicious MOD value, was '*'* intended'??.m?", Mod_Expr); end if; -- Proceed with analysis of mod expression @@ -21296,7 +21301,7 @@ package body Sem_Ch3 is goto Leave; end; - -- For non-concurrent types, transfer explicit primitives, but + -- For nonconcurrent types, transfer explicit primitives, but -- omit those inherited from the parent of the private view -- since they will be re-inherited later on. @@ -21641,11 +21646,10 @@ package body Sem_Ch3 is -------------------------------- procedure Process_Range_Expr_In_Decl - (R : Node_Id; - T : Entity_Id; - Subtyp : Entity_Id := Empty; - Check_List : List_Id := No_List; - R_Check_Off : Boolean := False) + (R : Node_Id; + T : Entity_Id; + Subtyp : Entity_Id := Empty; + Check_List : List_Id := No_List) is Lo, Hi : Node_Id; R_Checks : Check_Result; @@ -21748,149 +21752,130 @@ package body Sem_Ch3 is -- represent the null range the Constraint_Error exception should -- not be raised. - -- ??? The following code should be cleaned up as follows + -- Capture values of bounds and generate temporaries for them + -- if needed, before applying checks, since checks may cause + -- duplication of the expression without forcing evaluation. - -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it - -- is done in the call to Range_Check (R, T); below + -- The forced evaluation removes side effects from expressions, + -- which should occur also in GNATprove mode. Otherwise, we end up + -- with unexpected insertions of actions at places where this is + -- not supposed to occur, e.g. on default parameters of a call. - -- 2. The use of R_Check_Off should be investigated and possibly - -- removed, this would clean up things a bit. + if Expander_Active or GNATprove_Mode then - if Is_Null_Range (Lo, Hi) then - null; + -- Call Force_Evaluation to create declarations as needed + -- to deal with side effects, and also create typ_FIRST/LAST + -- entities for bounds if we have a subtype name. - else - -- Capture values of bounds and generate temporaries for them - -- if needed, before applying checks, since checks may cause - -- duplication of the expression without forcing evaluation. - - -- The forced evaluation removes side effects from expressions, - -- which should occur also in GNATprove mode. Otherwise, we end up - -- with unexpected insertions of actions at places where this is - -- not supposed to occur, e.g. on default parameters of a call. - - if Expander_Active or GNATprove_Mode then - - -- Call Force_Evaluation to create declarations as needed to - -- deal with side effects, and also create typ_FIRST/LAST - -- entities for bounds if we have a subtype name. - - -- Note: we do this transformation even if expansion is not - -- active if we are in GNATprove_Mode since the transformation - -- is in general required to ensure that the resulting tree has - -- proper Ada semantics. - - Force_Evaluation - (Lo, Related_Id => Subtyp, Is_Low_Bound => True); - Force_Evaluation - (Hi, Related_Id => Subtyp, Is_High_Bound => True); - end if; + -- Note: we do this transformation even if expansion is not + -- active if we are in GNATprove_Mode since the transformation + -- is in general required to ensure that the resulting tree has + -- proper Ada semantics. - -- We use a flag here instead of suppressing checks on the type - -- because the type we check against isn't necessarily the place - -- where we put the check. - - if not R_Check_Off then - R_Checks := Get_Range_Checks (R, T); - - -- Look up tree to find an appropriate insertion point. We - -- can't just use insert_actions because later processing - -- depends on the insertion node. Prior to Ada 2012 the - -- insertion point could only be a declaration or a loop, but - -- quantified expressions can appear within any context in an - -- expression, and the insertion point can be any statement, - -- pragma, or declaration. - - Insert_Node := Parent (R); - while Present (Insert_Node) loop - exit when - Nkind (Insert_Node) in N_Declaration - and then - Nkind (Insert_Node) not in N_Component_Declaration - | N_Loop_Parameter_Specification - | N_Function_Specification - | N_Procedure_Specification; - - exit when Nkind (Insert_Node) in - N_Later_Decl_Item | - N_Statement_Other_Than_Procedure_Call | - N_Procedure_Call_Statement | - N_Pragma; - - Insert_Node := Parent (Insert_Node); - end loop; + Force_Evaluation + (Lo, Related_Id => Subtyp, Is_Low_Bound => True); + Force_Evaluation + (Hi, Related_Id => Subtyp, Is_High_Bound => True); + end if; - -- Why would Type_Decl not be present??? Without this test, - -- short regression tests fail. + -- We use a flag here instead of suppressing checks on the type + -- because the type we check against isn't necessarily the place + -- where we put the check. - if Present (Insert_Node) then + R_Checks := Get_Range_Checks (R, T); - -- Case of loop statement. Verify that the range is part - -- of the subtype indication of the iteration scheme. + -- Look up tree to find an appropriate insertion point. We can't + -- just use insert_actions because later processing depends on + -- the insertion node. Prior to Ada 2012 the insertion point could + -- only be a declaration or a loop, but quantified expressions can + -- appear within any context in an expression, and the insertion + -- point can be any statement, pragma, or declaration. - if Nkind (Insert_Node) = N_Loop_Statement then - declare - Indic : Node_Id; + Insert_Node := Parent (R); + while Present (Insert_Node) loop + exit when + Nkind (Insert_Node) in N_Declaration + and then + Nkind (Insert_Node) not in N_Component_Declaration + | N_Loop_Parameter_Specification + | N_Function_Specification + | N_Procedure_Specification; + + exit when Nkind (Insert_Node) in + N_Later_Decl_Item | + N_Statement_Other_Than_Procedure_Call | + N_Procedure_Call_Statement | + N_Pragma; + + Insert_Node := Parent (Insert_Node); + end loop; - begin - Indic := Parent (R); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; + if Present (Insert_Node) then - if Present (Indic) then - Def_Id := Etype (Subtype_Mark (Indic)); + -- Case of loop statement. Verify that the range is part of the + -- subtype indication of the iteration scheme. - Insert_Range_Checks - (R_Checks, - Insert_Node, - Def_Id, - Sloc (Insert_Node), - Do_Before => True); - end if; - end; + if Nkind (Insert_Node) = N_Loop_Statement then + declare + Indic : Node_Id; - -- Case of declarations. If the declaration is for a type - -- and involves discriminants, the checks are premature at - -- the declaration point and need to wait for the expansion - -- of the initialization procedure, which will pass in the - -- list to put them on; otherwise, the checks are done at - -- the declaration point and there is no need to do them - -- again in the initialization procedure. + begin + Indic := Parent (R); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; - elsif Nkind (Insert_Node) in N_Declaration then - Def_Id := Defining_Identifier (Insert_Node); + if Present (Indic) then + Def_Id := Etype (Subtype_Mark (Indic)); - if (Ekind (Def_Id) = E_Record_Type - and then Depends_On_Discriminant (R)) - or else - (Ekind (Def_Id) = E_Protected_Type - and then Has_Discriminants (Def_Id)) - then - if Present (Check_List) then - Append_Range_Checks - (R_Checks, - Check_List, Def_Id, Sloc (Insert_Node)); - end if; + Insert_Range_Checks + (R_Checks, + Insert_Node, + Def_Id, + Sloc (Insert_Node), + Do_Before => True); + end if; + end; - else - if No (Check_List) then - Insert_Range_Checks - (R_Checks, - Insert_Node, Def_Id, Sloc (Insert_Node)); - end if; - end if; + -- Case of declarations. If the declaration is for a type and + -- involves discriminants, the checks are premature at the + -- declaration point and need to wait for the expansion of the + -- initialization procedure, which will pass in the list to put + -- them on; otherwise, the checks are done at the declaration + -- point and there is no need to do them again in the + -- initialization procedure. - -- Case of statements. Drop the checks, as the range appears - -- in the context of a quantified expression. Insertion will - -- take place when expression is expanded. + elsif Nkind (Insert_Node) in N_Declaration then + Def_Id := Defining_Identifier (Insert_Node); - else - null; + if (Ekind (Def_Id) = E_Record_Type + and then Depends_On_Discriminant (R)) + or else + (Ekind (Def_Id) = E_Protected_Type + and then Has_Discriminants (Def_Id)) + then + if Present (Check_List) then + Append_Range_Checks + (R_Checks, + Check_List, Def_Id, Sloc (Insert_Node)); + end if; + + else + if No (Check_List) then + Insert_Range_Checks + (R_Checks, + Insert_Node, Def_Id, Sloc (Insert_Node)); end if; end if; + + -- Case of statements. Drop the checks, as the range appears in + -- the context of a quantified expression. Insertion will take + -- place when expression is expanded. + + else + null; end if; end if; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index eedb98c..f3722a0 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -257,11 +257,10 @@ package Sem_Ch3 is -- Priv_T is the private view of the type whose full declaration is in N. procedure Process_Range_Expr_In_Decl - (R : Node_Id; - T : Entity_Id; - Subtyp : Entity_Id := Empty; - Check_List : List_Id := No_List; - R_Check_Off : Boolean := False); + (R : Node_Id; + T : Entity_Id; + Subtyp : Entity_Id := Empty; + Check_List : List_Id := No_List); -- Process a range expression that appears in a declaration context. The -- range is analyzed and resolved with the base type of the given type, and -- an appropriate check for expressions in non-static contexts made on the @@ -271,8 +270,7 @@ package Sem_Ch3 is -- pointer of R so that the types get properly frozen. Check_List is used -- when the subprogram is called from Build_Record_Init_Proc and is used to -- return a set of constraint checking statements generated by the Checks - -- package. R_Check_Off is set to True when the call to Range_Check is to - -- be skipped. + -- package. -- -- If Subtyp is given, then the range is for the named subtype Subtyp, and -- in this case the bounds are captured if necessary using this name. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 543ba12..22039f5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -281,6 +281,19 @@ package body Sem_Ch4 is -- type is not directly visible. The routine uses this type to emit a more -- informative message. + function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean; + -- Ada_2022: if an operand is a literal it may be subject to an + -- implicit conversion to a type for which a user-defined literal + -- function exists. During the first pass of type resolution we do + -- not know the context imposed on the literal, so we assume that + -- the literal type is a valid candidate and rely on the second pass + -- of resolution to find the type with the proper aspect. We only + -- add this interpretation if no other one was found, which may be + -- too restrictive but seems sufficient to handle most proper uses + -- of the new aspect. It is unclear whether a full implementation of + -- these aspects can be achieved without larger modifications to the + -- two-pass resolution algorithm. + procedure Remove_Abstract_Operations (N : Node_Id); -- Ada 2005: implementation of AI-310. An abstract non-dispatching -- operation is not a candidate interpretation. @@ -2534,6 +2547,7 @@ package body Sem_Ch4 is and then Is_Entity_Name (Actual) and then Is_Type (Entity (Actual)) and then Is_Discrete_Type (Entity (Actual)) + and then not Is_Current_Instance (Actual) then Replace (N, Make_Slice (Loc, @@ -2956,47 +2970,23 @@ package body Sem_Ch4 is I_F : Interp_Index; T_F : Entity_Id; + procedure Analyze_Set_Membership; + -- If a set of alternatives is present, analyze each and find the + -- common type to which they must all resolve. + + procedure Find_Interpretation; + function Find_Interpretation return Boolean; + -- Routine and wrapper to find a matching interpretation in case + -- of overloading. The wrapper returns True iff a matching + -- interpretation is found. Beware, in absence of overloading, + -- using this function will break gnat's bootstrapping. + procedure Try_One_Interp (T1 : Entity_Id); -- Routine to try one proposed interpretation. Note that the context -- of the operation plays no role in resolving the arguments, so that -- if there is more than one interpretation of the operands that is -- compatible with a membership test, the operation is ambiguous. - -------------------- - -- Try_One_Interp -- - -------------------- - - procedure Try_One_Interp (T1 : Entity_Id) is - begin - if Has_Compatible_Type (R, T1) then - if Found - and then Base_Type (T1) /= Base_Type (T_F) - then - It := Disambiguate (L, I_F, Index, Any_Type); - - if It = No_Interp then - Ambiguous_Operands (N); - Set_Etype (L, Any_Type); - return; - - else - T_F := It.Typ; - end if; - - else - Found := True; - T_F := T1; - I_F := Index; - end if; - - Set_Etype (L, T_F); - end if; - end Try_One_Interp; - - procedure Analyze_Set_Membership; - -- If a set of alternatives is present, analyze each and find the - -- common type to which they must all resolve. - ---------------------------- -- Analyze_Set_Membership -- ---------------------------- @@ -3095,6 +3085,57 @@ package body Sem_Ch4 is end if; end Analyze_Set_Membership; + ------------------------- + -- Find_Interpretation -- + ------------------------- + + procedure Find_Interpretation is + begin + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Try_One_Interp (It.Typ); + Get_Next_Interp (Index, It); + end loop; + end Find_Interpretation; + + function Find_Interpretation return Boolean is + begin + Find_Interpretation; + + return Found; + end Find_Interpretation; + + -------------------- + -- Try_One_Interp -- + -------------------- + + procedure Try_One_Interp (T1 : Entity_Id) is + begin + if Has_Compatible_Type (R, T1) then + if Found + and then Base_Type (T1) /= Base_Type (T_F) + then + It := Disambiguate (L, I_F, Index, Any_Type); + + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (L, Any_Type); + return; + + else + T_F := It.Typ; + end if; + + else + Found := True; + T_F := T1; + I_F := Index; + end if; + + Set_Etype (L, T_F); + end if; + end Try_One_Interp; + Op : Node_Id; -- Start of processing for Analyze_Membership_Op @@ -3119,11 +3160,7 @@ package body Sem_Ch4 is Try_One_Interp (Etype (L)); else - Get_First_Interp (L, Index, It); - while Present (It.Typ) loop - Try_One_Interp (It.Typ); - Get_Next_Interp (Index, It); - end loop; + Find_Interpretation; end if; -- If not a range, it can be a subtype mark, or else it is a degenerate @@ -3139,13 +3176,14 @@ package body Sem_Ch4 is Find_Type (R); Check_Fully_Declared (Entity (R), R); - elsif Ada_Version >= Ada_2012 - and then Has_Compatible_Type (R, Etype (L)) + elsif Ada_Version >= Ada_2012 and then + ((Is_Overloaded (L) and then Find_Interpretation) or else + (not Is_Overloaded (L) and then Has_Compatible_Type (R, Etype (L)))) then if Nkind (N) = N_In then - Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); + Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); else - Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); + Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); end if; if Is_Record_Or_Limited_Type (Etype (L)) then @@ -3204,7 +3242,7 @@ package body Sem_Ch4 is and then Intval (Right_Opnd (Parent (N))) <= Uint_128 then Error_Msg_N - ("suspicious MOD value, was '*'* intended'??M?", Parent (N)); + ("suspicious MOD value, was '*'* intended'??.m?", Parent (N)); end if; -- Remaining processing is same as for other arithmetic operators @@ -4274,21 +4312,67 @@ package body Sem_Ch4 is Loop_Id := Defining_Identifier (Loop_Parameter_Specification (N)); end if; - if Warn_On_Suspicious_Contract - and then not Referenced (Loop_Id, Cond) - and then not Is_Internal_Name (Chars (Loop_Id)) - then - -- Generating C, this check causes spurious warnings on inlined - -- postconditions; we can safely disable it because this check - -- was previously performed when analyzing the internally built - -- postconditions procedure. + declare + type Subexpr_Kind is (Full, Conjunct, Disjunct); - if Modify_Tree_For_C and then In_Inlined_Body then - null; - else - Error_Msg_N ("?T?unused variable &", Loop_Id); + procedure Check_Subexpr (Expr : Node_Id; Kind : Subexpr_Kind); + -- Check that the quantified variable appears in every sub-expression + -- of the quantified expression. If Kind is Full, Expr is the full + -- expression. If Kind is Conjunct (resp. Disjunct), Expr is a + -- conjunct (resp. disjunct) of the full expression. + + ------------------- + -- Check_Subexpr -- + ------------------- + + procedure Check_Subexpr (Expr : Node_Id; Kind : Subexpr_Kind) is + begin + if Nkind (Expr) in N_Op_And | N_And_Then + and then Kind /= Disjunct + then + Check_Subexpr (Left_Opnd (Expr), Conjunct); + Check_Subexpr (Right_Opnd (Expr), Conjunct); + + elsif Nkind (Expr) in N_Op_Or | N_Or_Else + and then Kind /= Conjunct + then + Check_Subexpr (Left_Opnd (Expr), Disjunct); + Check_Subexpr (Right_Opnd (Expr), Disjunct); + + elsif Kind /= Full + and then not Referenced (Loop_Id, Expr) + then + declare + Sub : constant String := + (if Kind = Conjunct then "conjunct" else "disjunct"); + begin + Error_Msg_NE + ("?.t?unused variable & in " & Sub, Expr, Loop_Id); + Error_Msg_NE + ("\consider extracting " & Sub & " from quantified " + & "expression", Expr, Loop_Id); + end; + end if; + end Check_Subexpr; + + begin + if Warn_On_Suspicious_Contract + and then not Is_Internal_Name (Chars (Loop_Id)) + + -- Generating C, this check causes spurious warnings on inlined + -- postconditions; we can safely disable it because this check + -- was previously performed when analyzing the internally built + -- postconditions procedure. + + and then not (Modify_Tree_For_C and In_Inlined_Body) + then + if not Referenced (Loop_Id, Cond) then + Error_Msg_N ("?.t?unused variable &", Loop_Id); + else + Check_Subexpr (Cond, Kind => Full); + end if; end if; - end if; + end; -- Diagnose a possible misuse of the SOME existential quantifier. When -- we have a quantified expression of the form: @@ -4304,7 +4388,7 @@ package body Sem_Ch4 is and then Nkind (Cond) = N_If_Expression and then No_Else_Or_Trivial_True (Cond) then - Error_Msg_N ("?T?suspicious expression", N); + Error_Msg_N ("?.t?suspicious expression", N); Error_Msg_N ("\\did you mean (for all X ='> (if P then Q))", N); Error_Msg_N ("\\or (for some X ='> P and then Q) instead'?", N); end if; @@ -7470,6 +7554,9 @@ package body Sem_Ch4 is then return; + elsif Has_Possible_Literal_Aspects (N) then + return; + -- If we have a logical operator, one of whose operands is -- Boolean, then we know that the other operand cannot resolve to -- Boolean (since we got no interpretations), but in that case we @@ -7786,6 +7873,69 @@ package body Sem_Ch4 is end if; end Operator_Check; + ---------------------------------- + -- Has_Possible_Literal_Aspects -- + ---------------------------------- + + function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean is + R : constant Node_Id := Right_Opnd (N); + L : Node_Id := Empty; + + procedure Check_Literal_Opnd (Opnd : Node_Id); + -- If an operand is a literal to which an aspect may apply, + -- add the corresponding type to operator node. + + ------------------------ + -- Check_Literal_Opnd -- + ------------------------ + + procedure Check_Literal_Opnd (Opnd : Node_Id) is + begin + if Nkind (Opnd) in N_Numeric_Or_String_Literal + or else (Is_Entity_Name (Opnd) + and then Present (Entity (Opnd)) + and then Is_Named_Number (Entity (Opnd))) + then + Add_One_Interp (N, Etype (Opnd), Etype (Opnd)); + end if; + end Check_Literal_Opnd; + + -- Start of processing for Has_Possible_Literal_Aspects + + begin + if Ada_Version < Ada_2022 then + return False; + end if; + + if Nkind (N) in N_Binary_Op then + L := Left_Opnd (N); + else + L := Empty; + end if; + Check_Literal_Opnd (R); + + -- Check left operand only if right one did not provide a + -- possible interpretation. Note that literal types are not + -- overloadable, in the sense that there is no overloadable + -- entity name whose several interpretations can be used to + -- indicate possible resulting types, so there is no way to + -- provide more than one interpretation to the operator node. + -- The choice of one operand over the other is arbitrary at + -- this point, and may lead to spurious resolution when both + -- operands are literals of different kinds, but the second + -- pass of resolution will examine anew both operands to + -- determine whether a user-defined literal may apply to + -- either or both. + + if Present (L) + and then Etype (N) = Any_Type + then + Check_Literal_Opnd (L); + end if; + + return Etype (N) /= Any_Type; + end Has_Possible_Literal_Aspects; + -------------------------------- -- Remove_Abstract_Operations -- -------------------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 45d2457..e62161a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -682,6 +682,7 @@ package body Sem_Ch5 is Ent := Lhs; while Nkind (Ent) in N_Has_Entity and then Present (Entity (Ent)) + and then Is_Object (Entity (Ent)) and then Present (Renamed_Object (Entity (Ent))) loop Ent := Renamed_Object (Entity (Ent)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e32c4ad..af8756b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -90,6 +90,7 @@ with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; with Validsw; use Validsw; +with Warnsw; use Warnsw; package body Sem_Ch6 is @@ -806,6 +807,7 @@ package body Sem_Ch6 is Assoc_Expr : Node_Id; Assoc_Present : Boolean := False; + Check_Cond : Node_Id; Unseen_Disc_Count : Nat := 0; Seen_Discs : Elist_Id; Disc : Entity_Id; @@ -1179,36 +1181,39 @@ package body Sem_Ch6 is and then Present (Disc) and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type then - -- Perform a static check first, if possible + -- Generate a dynamic check based on the extra accessibility of + -- the result or the scope. + + Check_Cond := + Make_Op_Gt (Loc, + Left_Opnd => Accessibility_Level + (Expr => Assoc_Expr, + Level => Dynamic_Level, + In_Return_Context => True), + Right_Opnd => (if Present + (Extra_Accessibility_Of_Result + (Scope_Id)) + then + Extra_Accessibility_Of_Result (Scope_Id) + else + Make_Integer_Literal + (Loc, Scope_Depth (Scope (Scope_Id))))); + + Insert_Before_And_Analyze (Return_Stmt, + Make_Raise_Program_Error (Loc, + 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. - if Static_Accessibility_Level - (Expr => Assoc_Expr, - Level => Zero_On_Dynamic_Level, - In_Return_Context => True) - > Scope_Depth (Scope (Scope_Id)) + if Nkind (Check_Cond) = N_Identifier + and then Entity (Check_Cond) = Standard_True then Error_Msg_N ("access discriminant in return object would be a dangling" & " reference", Return_Stmt); - - exit; - end if; - - -- Otherwise, generate a dynamic check based on the extra - -- accessibility of the result. - - if Present (Extra_Accessibility_Of_Result (Scope_Id)) then - Insert_Before_And_Analyze (Return_Stmt, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Accessibility_Level - (Expr => Assoc_Expr, - Level => Dynamic_Level, - In_Return_Context => True), - Right_Opnd => Extra_Accessibility_Of_Result - (Scope_Id)), - Reason => PE_Accessibility_Check_Failed)); end if; end if; @@ -5962,6 +5967,17 @@ package body Sem_Ch6 is -- True if the null exclusions of two formals of anonymous access type -- match. + function Subprogram_Subtypes_Have_Same_Declaration + (Subp : Entity_Id; + Decl_Subtype : Entity_Id; + Body_Subtype : Entity_Id) return Boolean; + -- Checks whether corresponding subtypes named within a subprogram + -- declaration and body originate from the same declaration, and returns + -- True when they do. In the case of anonymous access-to-object types, + -- checks the designated types. Also returns True when GNAT_Mode is + -- enabled, or when the subprogram is marked Is_Internal or occurs + -- within a generic instantiation or internal unit (GNAT library unit). + ----------------------- -- Conformance_Error -- ----------------------- @@ -6094,6 +6110,86 @@ package body Sem_Ch6 is end if; end Null_Exclusions_Match; + function Subprogram_Subtypes_Have_Same_Declaration + (Subp : Entity_Id; + Decl_Subtype : Entity_Id; + Body_Subtype : Entity_Id) return Boolean + is + + function Nonlimited_View_Of_Subtype + (Subt : Entity_Id) return Entity_Id; + -- Returns the nonlimited view of a type or subtype that is an + -- incomplete or class-wide type that comes from a limited view of + -- a package (From_Limited_With is True for the entity), or the + -- full view when the subtype is an incomplete type. Otherwise + -- returns the entity passed in. + + function Nonlimited_View_Of_Subtype + (Subt : Entity_Id) return Entity_Id + is + Subt_Temp : Entity_Id := Subt; + begin + if Ekind (Subt) in Incomplete_Kind | E_Class_Wide_Type + and then From_Limited_With (Subt) + then + Subt_Temp := Non_Limited_View (Subt); + end if; + + -- If the subtype is incomplete, return full view if present + -- (and accounts for the case where a type from a limited view + -- is itself an incomplete type). + + if Ekind (Subt_Temp) in Incomplete_Kind + and then Present (Full_View (Subt_Temp)) + then + Subt_Temp := Full_View (Subt_Temp); + end if; + + return Subt_Temp; + end Nonlimited_View_Of_Subtype; + + -- Start of processing for Subprogram_Subtypes_Have_Same_Declaration + + begin + if not In_Instance + and then not In_Internal_Unit (Subp) + and then not Is_Internal (Subp) + and then not GNAT_Mode + and then + Ekind (Etype (Decl_Subtype)) not in Access_Subprogram_Kind + then + if Ekind (Etype (Decl_Subtype)) = E_Anonymous_Access_Type then + if Nonlimited_View_Of_Subtype (Designated_Type (Decl_Subtype)) + /= Nonlimited_View_Of_Subtype (Designated_Type (Body_Subtype)) + then + return False; + end if; + + elsif Nonlimited_View_Of_Subtype (Decl_Subtype) + /= Nonlimited_View_Of_Subtype (Body_Subtype) + then + -- Avoid returning False (and a false-positive warning) for + -- the case of "not null" itypes, which will appear to be + -- different subtypes even when the subtype_marks denote + -- the same subtype. + + if Ekind (Decl_Subtype) = E_Access_Subtype + and then Ekind (Body_Subtype) = E_Access_Subtype + and then Is_Itype (Body_Subtype) + and then Can_Never_Be_Null (Body_Subtype) + and then Etype (Decl_Subtype) = Etype (Body_Subtype) + then + return True; + + else + return False; + end if; + end if; + end if; + + return True; + end Subprogram_Subtypes_Have_Same_Declaration; + -- Local Variables Old_Type : constant Entity_Id := Etype (Old_Id); @@ -6147,6 +6243,18 @@ package body Sem_Ch6 is end if; return; + + -- If the result subtypes conform and pedantic checks are enabled, + -- check to see whether the subtypes originate from different + -- declarations, and issue a warning when they do. + + elsif Ctype = Fully_Conformant + and then Warn_On_Pedantic_Checks + and then not Subprogram_Subtypes_Have_Same_Declaration + (Old_Id, Old_Type, New_Type) + then + Error_Msg_N ("result subtypes conform but come from different " + & "declarations?_p?", New_Id); end if; -- Ada 2005 (AI-231): In case of anonymous access types check the @@ -6343,6 +6451,18 @@ package body Sem_Ch6 is end if; return; + + -- If the formals' subtypes conform and pedantic checks are enabled, + -- check to see whether the subtypes originate from different + -- declarations, and issue a warning when they do. + + elsif Ctype = Fully_Conformant + and then Warn_On_Pedantic_Checks + and then not Subprogram_Subtypes_Have_Same_Declaration + (Old_Id, Old_Formal_Base, New_Formal_Base) + then + Error_Msg_N ("formal subtypes conform but come from " + & "different declarations?_p?", New_Formal); end if; -- For mode conformance, mode must match @@ -10798,11 +10918,11 @@ package body Sem_Ch6 is if Pragma_Name (Prag) = Name_Precondition then Error_Msg_N ("info: & inherits `Pre''Class` aspect from " - & "#?L?", E); + & "#?.l?", E); else Error_Msg_N ("info: & inherits `Post''Class` aspect from " - & "#?L?", E); + & "#?.l?", E); end if; end if; @@ -11861,11 +11981,11 @@ package body Sem_Ch6 is -- renaming declaration becomes hidden. if Ekind (E) = E_Package - and then Present (Renamed_Object (E)) - and then Renamed_Object (E) = Current_Scope - and then Nkind (Parent (Renamed_Object (E))) = + and then Present (Renamed_Entity (E)) + and then Renamed_Entity (E) = Current_Scope + and then Nkind (Parent (Renamed_Entity (E))) = N_Package_Specification - and then Present (Generic_Parent (Parent (Renamed_Object (E)))) + and then Present (Generic_Parent (Parent (Renamed_Entity (E)))) then Set_Is_Hidden (E); Set_Is_Immediately_Visible (E, False); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 3852a9a..a0bddb1 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -3363,12 +3363,12 @@ package body Sem_Ch7 is -- Body required if library package with pragma Elaborate_Body elsif Has_Pragma_Elaborate_Body (Pack_Id) then - Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", Pack_Id); + Error_Msg_N ("info: & requires body (Elaborate_Body)?.y?", Pack_Id); -- Body required if subprogram elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then - Error_Msg_N ("info: & requires body (subprogram case)?Y?", Pack_Id); + Error_Msg_N ("info: & requires body (subprogram case)?.y?", Pack_Id); -- Body required if generic parent has Elaborate_Body @@ -3381,7 +3381,7 @@ package body Sem_Ch7 is begin if Has_Pragma_Elaborate_Body (G_P) then Error_Msg_N - ("info: & requires body (generic parent Elaborate_Body)?Y?", + ("info: & requires body (generic parent Elaborate_Body)?.y?", Pack_Id); end if; end; @@ -3399,7 +3399,7 @@ package body Sem_Ch7 is (Node (First_Elmt (Abstract_States (Pack_Id)))) then Error_Msg_N - ("info: & requires body (non-null abstract state aspect)?Y?", + ("info: & requires body (non-null abstract state aspect)?.y?", Pack_Id); end if; @@ -3410,7 +3410,8 @@ package body Sem_Ch7 is if Requires_Completion_In_Body (E, Pack_Id) then Error_Msg_Node_2 := E; Error_Msg_NE - ("info: & requires body (& requires completion)?Y?", E, Pack_Id); + ("info: & requires body (& requires completion)?.y?", E, + Pack_Id); end if; Next_Entity (E); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 494ec64..686d437 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -576,10 +576,10 @@ package body Sem_Ch8 is and then Present (Entity (Nam)) and then Ekind (Entity (Nam)) = E_Exception then - if Present (Renamed_Object (Entity (Nam))) then - Set_Renamed_Object (Id, Renamed_Object (Entity (Nam))); + if Present (Renamed_Entity (Entity (Nam))) then + Set_Renamed_Entity (Id, Renamed_Entity (Entity (Nam))); else - Set_Renamed_Object (Id, Entity (Nam)); + Set_Renamed_Entity (Id, Entity (Nam)); end if; -- The exception renaming declaration may become Ghost if it renames @@ -706,10 +706,10 @@ package body Sem_Ch8 is Error_Msg_N ("invalid generic unit name", Name (N)); else - if Present (Renamed_Object (Old_P)) then - Set_Renamed_Object (New_P, Renamed_Object (Old_P)); + if Present (Renamed_Entity (Old_P)) then + Set_Renamed_Entity (New_P, Renamed_Entity (Old_P)); else - Set_Renamed_Object (New_P, Old_P); + Set_Renamed_Entity (New_P, Old_P); end if; -- The generic renaming declaration may become Ghost if it renames a @@ -1327,13 +1327,13 @@ package body Sem_Ch8 is and then Comes_From_Source (Nam) then Error_Msg_N - ("renaming function result object is suspicious?R?", Nam); + ("renaming function result object is suspicious?.r?", Nam); Error_Msg_NE - ("\function & will be called only once?R?", Nam, + ("\function & will be called only once?.r?", Nam, Entity (Name (Nam))); Error_Msg_N -- CODEFIX ("\suggest using an initialized constant object " - & "instead?R?", Nam); + & "instead?.r?", Nam); end if; end case; end if; @@ -1658,10 +1658,10 @@ package body Sem_Ch8 is Mutate_Ekind (New_P, E_Package); Set_Etype (New_P, Standard_Void_Type); - if Present (Renamed_Object (Old_P)) then - Set_Renamed_Object (New_P, Renamed_Object (Old_P)); + if Present (Renamed_Entity (Old_P)) then + Set_Renamed_Entity (New_P, Renamed_Entity (Old_P)); else - Set_Renamed_Object (New_P, Old_P); + Set_Renamed_Entity (New_P, Old_P); end if; -- The package renaming declaration may become Ghost if it renames a @@ -2109,42 +2109,6 @@ package body Sem_Ch8 is Old_S : Entity_Id := Empty; Rename_Spec : Entity_Id; - procedure Build_Class_Wide_Wrapper - (Ren_Id : out Entity_Id; - Wrap_Id : out Entity_Id); - -- Ada 2012 (AI05-0071): A generic/instance scenario involving a formal - -- type with unknown discriminants and a generic primitive operation of - -- the said type with a box require special processing when the actual - -- is a class-wide type: - -- - -- generic - -- type Formal_Typ (<>) is private; - -- with procedure Prim_Op (Param : Formal_Typ) is <>; - -- package Gen is ... - -- - -- package Inst is new Gen (Actual_Typ'Class); - -- - -- In this case the general renaming mechanism used in the prologue of - -- an instance no longer applies: - -- - -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; - -- - -- The above is replaced the following wrapper/renaming combination: - -- - -- procedure Wrapper (Param : Formal_Typ) is -- wrapper - -- begin - -- Prim_Op (Param); -- primitive - -- end Wrapper; - -- - -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper; - -- - -- This transformation applies only if there is no explicit visible - -- class-wide operation at the point of the instantiation. Ren_Id is - -- the entity of the renaming declaration. When the transformation - -- applies, Wrap_Id is the entity of the generated class-wide wrapper - -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide - -- operation. - procedure Check_Null_Exclusion (Ren : Entity_Id; Sub : Entity_Id); @@ -2170,9 +2134,21 @@ package body Sem_Ch8 is -- incomplete untagged formal (RM 13.14(10.2/3)). function Has_Class_Wide_Actual return Boolean; - -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a - -- defaulted formal subprogram where the actual for the controlling - -- formal type is class-wide. + -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if N is + -- the renaming for a defaulted formal subprogram where the actual for + -- the controlling formal type is class-wide. + + procedure Handle_Instance_With_Class_Wide_Type + (Inst_Node : Node_Id; + Ren_Id : Entity_Id; + Wrapped_Prim : out Entity_Id; + Wrap_Id : out Entity_Id); + -- Ada 2012 (AI05-0071), Ada 2022 (AI12-0165): when the actual type + -- of an instantiation is a class-wide type T'Class we may need to + -- wrap a primitive operation of T; this routine looks for a suitable + -- primitive to be wrapped and (if the wrapper is required) returns the + -- Id of the wrapped primitive and the Id of the built wrapper. Ren_Id + -- is the defining entity for the renamed subprogram specification. function Original_Subprogram (Subp : Entity_Id) return Entity_Id; -- Find renamed entity when the declaration is a renaming_as_body and @@ -2181,550 +2157,6 @@ package body Sem_Ch8 is -- before the subprogram it completes is frozen, and renaming indirectly -- renames the subprogram itself.(Defect Report 8652/0027). - ------------------------------ - -- Build_Class_Wide_Wrapper -- - ------------------------------ - - procedure Build_Class_Wide_Wrapper - (Ren_Id : out Entity_Id; - Wrap_Id : out Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - - function Build_Call - (Subp_Id : Entity_Id; - Params : List_Id) return Node_Id; - -- Create a dispatching call to invoke routine Subp_Id with actuals - -- built from the parameter specifications of list Params. - - function Build_Expr_Fun_Call - (Subp_Id : Entity_Id; - Params : List_Id) return Node_Id; - -- Create a dispatching call to invoke function Subp_Id with actuals - -- built from the parameter specifications of list Params. Return - -- directly the call, so that it can be used inside an expression - -- function. This is a specificity of the GNATprove mode. - - function Build_Spec (Subp_Id : Entity_Id) return Node_Id; - -- Create a subprogram specification based on the subprogram profile - -- of Subp_Id. - - function Find_Primitive (Typ : Entity_Id) return Entity_Id; - -- Find a primitive subprogram of type Typ which matches the profile - -- of the renaming declaration. - - procedure Interpretation_Error (Subp_Id : Entity_Id); - -- Emit a continuation error message suggesting subprogram Subp_Id as - -- a possible interpretation. - - function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean; - -- Determine whether subprogram Subp_Id denotes the intrinsic "=" - -- operator. - - function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean; - -- Determine whether subprogram Subp_Id is a suitable candidate for - -- the role of a wrapped subprogram. - - ---------------- - -- Build_Call -- - ---------------- - - function Build_Call - (Subp_Id : Entity_Id; - Params : List_Id) return Node_Id - is - Actuals : constant List_Id := New_List; - Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); - Formal : Node_Id; - - begin - -- Build the actual parameters of the call - - Formal := First (Params); - while Present (Formal) loop - Append_To (Actuals, - Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); - Next (Formal); - end loop; - - -- Generate: - -- return Subp_Id (Actuals); - - if Ekind (Subp_Id) in E_Function | E_Operator then - return - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => Call_Ref, - Parameter_Associations => Actuals)); - - -- Generate: - -- Subp_Id (Actuals); - - else - return - Make_Procedure_Call_Statement (Loc, - Name => Call_Ref, - Parameter_Associations => Actuals); - end if; - end Build_Call; - - ------------------------- - -- Build_Expr_Fun_Call -- - ------------------------- - - function Build_Expr_Fun_Call - (Subp_Id : Entity_Id; - Params : List_Id) return Node_Id - is - Actuals : constant List_Id := New_List; - Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); - Formal : Node_Id; - - begin - pragma Assert (Ekind (Subp_Id) in E_Function | E_Operator); - - -- Build the actual parameters of the call - - Formal := First (Params); - while Present (Formal) loop - Append_To (Actuals, - Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); - Next (Formal); - end loop; - - -- Generate: - -- Subp_Id (Actuals); - - return - Make_Function_Call (Loc, - Name => Call_Ref, - Parameter_Associations => Actuals); - end Build_Expr_Fun_Call; - - ---------------- - -- Build_Spec -- - ---------------- - - function Build_Spec (Subp_Id : Entity_Id) return Node_Id is - Params : constant List_Id := Copy_Parameter_List (Subp_Id); - Spec_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Subp_Id), 'R')); - - begin - if Ekind (Formal_Spec) = E_Procedure then - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Spec_Id, - Parameter_Specifications => Params); - else - return - Make_Function_Specification (Loc, - Defining_Unit_Name => Spec_Id, - Parameter_Specifications => Params, - Result_Definition => - New_Copy_Tree (Result_Definition (Spec))); - end if; - end Build_Spec; - - -------------------- - -- Find_Primitive -- - -------------------- - - function Find_Primitive (Typ : Entity_Id) return Entity_Id is - procedure Replace_Parameter_Types (Spec : Node_Id); - -- Given a specification Spec, replace all class-wide parameter - -- types with reference to type Typ. - - ----------------------------- - -- Replace_Parameter_Types -- - ----------------------------- - - procedure Replace_Parameter_Types (Spec : Node_Id) is - Formal : Node_Id; - Formal_Id : Entity_Id; - Formal_Typ : Node_Id; - - begin - Formal := First (Parameter_Specifications (Spec)); - while Present (Formal) loop - Formal_Id := Defining_Identifier (Formal); - Formal_Typ := Parameter_Type (Formal); - - -- Create a new entity for each class-wide formal to prevent - -- aliasing with the original renaming. Replace the type of - -- such a parameter with the candidate type. - - if Nkind (Formal_Typ) = N_Identifier - and then Is_Class_Wide_Type (Etype (Formal_Typ)) - then - Set_Defining_Identifier (Formal, - Make_Defining_Identifier (Loc, Chars (Formal_Id))); - - Set_Parameter_Type (Formal, New_Occurrence_Of (Typ, Loc)); - end if; - - Next (Formal); - end loop; - end Replace_Parameter_Types; - - -- Local variables - - Alt_Ren : constant Node_Id := New_Copy_Tree (N); - Alt_Nam : constant Node_Id := Name (Alt_Ren); - Alt_Spec : constant Node_Id := Specification (Alt_Ren); - Subp_Id : Entity_Id; - - -- Start of processing for Find_Primitive - - begin - -- Each attempt to find a suitable primitive of a particular type - -- operates on its own copy of the original renaming. As a result - -- the original renaming is kept decoration and side-effect free. - - -- Inherit the overloaded status of the renamed subprogram name - - if Is_Overloaded (Nam) then - Set_Is_Overloaded (Alt_Nam); - Save_Interps (Nam, Alt_Nam); - end if; - - -- The copied renaming is hidden from visibility to prevent the - -- pollution of the enclosing context. - - Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R')); - - -- The types of all class-wide parameters must be changed to the - -- candidate type. - - Replace_Parameter_Types (Alt_Spec); - - -- Try to find a suitable primitive which matches the altered - -- profile of the renaming specification. - - Subp_Id := - Find_Renamed_Entity - (N => Alt_Ren, - Nam => Name (Alt_Ren), - New_S => Analyze_Subprogram_Specification (Alt_Spec), - Is_Actual => Is_Actual); - - -- Do not return Any_Id if the resolion of the altered profile - -- failed as this complicates further checks on the caller side, - -- return Empty instead. - - if Subp_Id = Any_Id then - return Empty; - else - return Subp_Id; - end if; - end Find_Primitive; - - -------------------------- - -- Interpretation_Error -- - -------------------------- - - procedure Interpretation_Error (Subp_Id : Entity_Id) is - begin - Error_Msg_Sloc := Sloc (Subp_Id); - - if Is_Internal (Subp_Id) then - Error_Msg_NE - ("\\possible interpretation: predefined & #", - Spec, Formal_Spec); - else - Error_Msg_NE - ("\\possible interpretation: & defined #", Spec, Formal_Spec); - end if; - end Interpretation_Error; - - --------------------------- - -- Is_Intrinsic_Equality -- - --------------------------- - - function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean is - begin - return - Ekind (Subp_Id) = E_Operator - and then Chars (Subp_Id) = Name_Op_Eq - and then Is_Intrinsic_Subprogram (Subp_Id); - end Is_Intrinsic_Equality; - - --------------------------- - -- Is_Suitable_Candidate -- - --------------------------- - - function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean is - begin - if No (Subp_Id) then - return False; - - -- An intrinsic subprogram is never a good candidate. This is an - -- indication of a missing primitive, either defined directly or - -- inherited from a parent tagged type. - - elsif Is_Intrinsic_Subprogram (Subp_Id) then - return False; - - else - return True; - end if; - end Is_Suitable_Candidate; - - -- Local variables - - Actual_Typ : Entity_Id := Empty; - -- The actual class-wide type for Formal_Typ - - CW_Prim_OK : Boolean; - CW_Prim_Op : Entity_Id; - -- The class-wide subprogram (if available) which corresponds to the - -- renamed generic formal subprogram. - - Formal_Typ : Entity_Id := Empty; - -- The generic formal type with unknown discriminants - - Root_Prim_OK : Boolean; - Root_Prim_Op : Entity_Id; - -- The root type primitive (if available) which corresponds to the - -- renamed generic formal subprogram. - - Root_Typ : Entity_Id := Empty; - -- The root type of Actual_Typ - - Body_Decl : Node_Id; - Formal : Node_Id; - Prim_Op : Entity_Id; - Spec_Decl : Node_Id; - New_Spec : Node_Id; - - -- Start of processing for Build_Class_Wide_Wrapper - - begin - -- Analyze the specification of the renaming in case the generation - -- of the class-wide wrapper fails. - - Ren_Id := Analyze_Subprogram_Specification (Spec); - Wrap_Id := Any_Id; - - -- Do not attempt to build a wrapper if the renaming is in error - - if Error_Posted (Nam) then - return; - end if; - - -- Analyze the renamed name, but do not resolve it. The resolution is - -- completed once a suitable subprogram is found. - - Analyze (Nam); - - -- When the renamed name denotes the intrinsic operator equals, the - -- name must be treated as overloaded. This allows for a potential - -- match against the root type's predefined equality function. - - if Is_Intrinsic_Equality (Entity (Nam)) then - Set_Is_Overloaded (Nam); - Collect_Interps (Nam); - end if; - - -- Step 1: Find the generic formal type with unknown discriminants - -- and its corresponding class-wide actual type from the renamed - -- generic formal subprogram. - - Formal := First_Formal (Formal_Spec); - while Present (Formal) loop - if Has_Unknown_Discriminants (Etype (Formal)) - and then not Is_Class_Wide_Type (Etype (Formal)) - and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) - then - Formal_Typ := Etype (Formal); - Actual_Typ := Base_Type (Get_Instance_Of (Formal_Typ)); - Root_Typ := Root_Type (Actual_Typ); - exit; - end if; - - Next_Formal (Formal); - end loop; - - -- The specification of the generic formal subprogram should always - -- contain a formal type with unknown discriminants whose actual is - -- a class-wide type, otherwise this indicates a failure in routine - -- Has_Class_Wide_Actual. - - pragma Assert (Present (Formal_Typ)); - - -- Step 2: Find the proper class-wide subprogram or primitive which - -- corresponds to the renamed generic formal subprogram. - - CW_Prim_Op := Find_Primitive (Actual_Typ); - CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); - Root_Prim_Op := Find_Primitive (Root_Typ); - Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); - - -- The class-wide actual type has two subprograms which correspond to - -- the renamed generic formal subprogram: - - -- with procedure Prim_Op (Param : Formal_Typ); - - -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited - -- procedure Prim_Op (Param : Actual_Typ'Class); - - -- Even though the declaration of the two subprograms is legal, a - -- call to either one is ambiguous and therefore illegal. - - if CW_Prim_OK and Root_Prim_OK then - - -- A user-defined primitive has precedence over a predefined one - - if Is_Internal (CW_Prim_Op) - and then not Is_Internal (Root_Prim_Op) - then - Prim_Op := Root_Prim_Op; - - elsif Is_Internal (Root_Prim_Op) - and then not Is_Internal (CW_Prim_Op) - then - Prim_Op := CW_Prim_Op; - - elsif CW_Prim_Op = Root_Prim_Op then - Prim_Op := Root_Prim_Op; - - -- The two subprograms are legal but the class-wide subprogram is - -- a class-wide wrapper built for a previous instantiation; the - -- wrapper has precedence. - - elsif Present (Alias (CW_Prim_Op)) - and then Is_Class_Wide_Wrapper (Ultimate_Alias (CW_Prim_Op)) - then - Prim_Op := CW_Prim_Op; - - -- Otherwise both candidate subprograms are user-defined and - -- ambiguous. - - else - Error_Msg_NE - ("ambiguous actual for generic subprogram &", - Spec, Formal_Spec); - Interpretation_Error (Root_Prim_Op); - Interpretation_Error (CW_Prim_Op); - return; - end if; - - elsif CW_Prim_OK and not Root_Prim_OK then - Prim_Op := CW_Prim_Op; - - elsif not CW_Prim_OK and Root_Prim_OK then - Prim_Op := Root_Prim_Op; - - -- An intrinsic equality may act as a suitable candidate in the case - -- of a null type extension where the parent's equality is hidden. A - -- call to an intrinsic equality is expanded as dispatching. - - elsif Present (Root_Prim_Op) - and then Is_Intrinsic_Equality (Root_Prim_Op) - then - Prim_Op := Root_Prim_Op; - - -- Otherwise there are no candidate subprograms. Let the caller - -- diagnose the error. - - else - return; - end if; - - -- At this point resolution has taken place and the name is no longer - -- overloaded. Mark the primitive as referenced. - - Set_Is_Overloaded (Name (N), False); - Set_Referenced (Prim_Op); - - -- Do not generate a wrapper when the only candidate is a class-wide - -- subprogram. Instead modify the renaming to directly map the actual - -- to the generic formal. - - if CW_Prim_OK and then Prim_Op = CW_Prim_Op then - Wrap_Id := Prim_Op; - Rewrite (Nam, New_Occurrence_Of (Prim_Op, Loc)); - return; - end if; - - -- Step 3: Create the declaration and the body of the wrapper, insert - -- all the pieces into the tree. - - -- In GNATprove mode, create a function wrapper in the form of an - -- expression function, so that an implicit postcondition relating - -- the result of calling the wrapper function and the result of the - -- dispatching call to the wrapped function is known during proof. - - if GNATprove_Mode - and then Ekind (Ren_Id) in E_Function | E_Operator - then - New_Spec := Build_Spec (Ren_Id); - Body_Decl := - Make_Expression_Function (Loc, - Specification => New_Spec, - Expression => - Build_Expr_Fun_Call - (Subp_Id => Prim_Op, - Params => Parameter_Specifications (New_Spec))); - - Wrap_Id := Defining_Entity (Body_Decl); - - -- Otherwise, create separate spec and body for the subprogram - - else - Spec_Decl := - Make_Subprogram_Declaration (Loc, - Specification => Build_Spec (Ren_Id)); - Insert_Before_And_Analyze (N, Spec_Decl); - - Wrap_Id := Defining_Entity (Spec_Decl); - - Body_Decl := - Make_Subprogram_Body (Loc, - Specification => Build_Spec (Ren_Id), - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Build_Call - (Subp_Id => Prim_Op, - Params => - Parameter_Specifications - (Specification (Spec_Decl)))))); - - Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); - end if; - - Set_Is_Class_Wide_Wrapper (Wrap_Id); - - -- If the operator carries an Eliminated pragma, indicate that the - -- wrapper is also to be eliminated, to prevent spurious error when - -- using gnatelim on programs that include box-initialization of - -- equality operators. - - Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op)); - - -- In GNATprove mode, insert the body in the tree for analysis - - if GNATprove_Mode then - Insert_Before_And_Analyze (N, Body_Decl); - end if; - - -- The generated body does not freeze and must be analyzed when the - -- class-wide wrapper is frozen. The body is only needed if expansion - -- is enabled. - - if Expander_Active then - Append_Freeze_Action (Wrap_Id, Body_Decl); - end if; - - -- Step 4: The subprogram renaming aliases the wrapper - - Rewrite (Nam, New_Occurrence_Of (Wrap_Id, Loc)); - end Build_Class_Wide_Wrapper; - -------------------------- -- Check_Null_Exclusion -- -------------------------- @@ -2919,6 +2351,703 @@ package body Sem_Ch8 is return False; end Has_Class_Wide_Actual; + ------------------------------------------ + -- Handle_Instance_With_Class_Wide_Type -- + ------------------------------------------ + + procedure Handle_Instance_With_Class_Wide_Type + (Inst_Node : Node_Id; + Ren_Id : Entity_Id; + Wrapped_Prim : out Entity_Id; + Wrap_Id : out Entity_Id) + is + procedure Build_Class_Wide_Wrapper + (Ren_Id : Entity_Id; + Prim_Op : Entity_Id; + Wrap_Id : out Entity_Id); + -- Build a wrapper for the renaming Ren_Id of subprogram Prim_Op. + + procedure Find_Suitable_Candidate + (Prim_Op : out Entity_Id; + Is_CW_Prim : out Boolean); + -- Look for a suitable primitive to be wrapped (Prim_Op); Is_CW_Prim + -- indicates that the found candidate is a class-wide primitive (to + -- help the caller decide if the wrapper is required). + + ------------------------------ + -- Build_Class_Wide_Wrapper -- + ------------------------------ + + procedure Build_Class_Wide_Wrapper + (Ren_Id : Entity_Id; + Prim_Op : Entity_Id; + Wrap_Id : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + function Build_Call + (Subp_Id : Entity_Id; + Params : List_Id) return Node_Id; + -- Create a dispatching call to invoke routine Subp_Id with + -- actuals built from the parameter specifications of list Params. + + function Build_Expr_Fun_Call + (Subp_Id : Entity_Id; + Params : List_Id) return Node_Id; + -- Create a dispatching call to invoke function Subp_Id with + -- actuals built from the parameter specifications of list Params. + -- Directly return the call, so that it can be used inside an + -- expression function. This is a requirement of GNATprove mode. + + function Build_Spec (Subp_Id : Entity_Id) return Node_Id; + -- Create a subprogram specification based on the subprogram + -- profile of Subp_Id. + + ---------------- + -- Build_Call -- + ---------------- + + function Build_Call + (Subp_Id : Entity_Id; + Params : List_Id) return Node_Id + is + Actuals : constant List_Id := New_List; + Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); + Formal : Node_Id; + + begin + -- Build the actual parameters of the call + + Formal := First (Params); + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, + Chars (Defining_Identifier (Formal)))); + Next (Formal); + end loop; + + -- Generate: + -- return Subp_Id (Actuals); + + if Ekind (Subp_Id) in E_Function | E_Operator then + return + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Call_Ref, + Parameter_Associations => Actuals)); + + -- Generate: + -- Subp_Id (Actuals); + + else + return + Make_Procedure_Call_Statement (Loc, + Name => Call_Ref, + Parameter_Associations => Actuals); + end if; + end Build_Call; + + ------------------------- + -- Build_Expr_Fun_Call -- + ------------------------- + + function Build_Expr_Fun_Call + (Subp_Id : Entity_Id; + Params : List_Id) return Node_Id + is + Actuals : constant List_Id := New_List; + Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); + Formal : Node_Id; + + begin + pragma Assert (Ekind (Subp_Id) in E_Function | E_Operator); + + -- Build the actual parameters of the call + + Formal := First (Params); + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, + Chars (Defining_Identifier (Formal)))); + Next (Formal); + end loop; + + -- Generate: + -- Subp_Id (Actuals); + + return + Make_Function_Call (Loc, + Name => Call_Ref, + Parameter_Associations => Actuals); + end Build_Expr_Fun_Call; + + ---------------- + -- Build_Spec -- + ---------------- + + function Build_Spec (Subp_Id : Entity_Id) return Node_Id is + Params : constant List_Id := Copy_Parameter_List (Subp_Id); + Spec_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Subp_Id), 'R')); + + begin + if Ekind (Formal_Spec) = E_Procedure then + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Params); + else + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Params, + Result_Definition => + New_Copy_Tree (Result_Definition (Spec))); + end if; + end Build_Spec; + + -- Local variables + + Body_Decl : Node_Id; + Spec_Decl : Node_Id; + New_Spec : Node_Id; + + -- Start of processing for Build_Class_Wide_Wrapper + + begin + pragma Assert (not Error_Posted (Nam)); + + -- Step 1: Create the declaration and the body of the wrapper, + -- insert all the pieces into the tree. + + -- In GNATprove mode, create a function wrapper in the form of an + -- expression function, so that an implicit postcondition relating + -- the result of calling the wrapper function and the result of + -- the dispatching call to the wrapped function is known during + -- proof. + + if GNATprove_Mode + and then Ekind (Ren_Id) in E_Function | E_Operator + then + New_Spec := Build_Spec (Ren_Id); + Body_Decl := + Make_Expression_Function (Loc, + Specification => New_Spec, + Expression => + Build_Expr_Fun_Call + (Subp_Id => Prim_Op, + Params => Parameter_Specifications (New_Spec))); + + Wrap_Id := Defining_Entity (Body_Decl); + + -- Otherwise, create separate spec and body for the subprogram + + else + Spec_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec (Ren_Id)); + Insert_Before_And_Analyze (N, Spec_Decl); + + Wrap_Id := Defining_Entity (Spec_Decl); + + Body_Decl := + Make_Subprogram_Body (Loc, + Specification => Build_Spec (Ren_Id), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Call + (Subp_Id => Prim_Op, + Params => + Parameter_Specifications + (Specification (Spec_Decl)))))); + + Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); + end if; + + Set_Is_Class_Wide_Wrapper (Wrap_Id); + + -- If the operator carries an Eliminated pragma, indicate that + -- the wrapper is also to be eliminated, to prevent spurious + -- errors when using gnatelim on programs that include box- + -- defaulted initialization of equality operators. + + Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op)); + + -- In GNATprove mode, insert the body in the tree for analysis + + if GNATprove_Mode then + Insert_Before_And_Analyze (N, Body_Decl); + end if; + + -- The generated body does not freeze and must be analyzed when + -- the class-wide wrapper is frozen. The body is only needed if + -- expansion is enabled. + + if Expander_Active then + Append_Freeze_Action (Wrap_Id, Body_Decl); + end if; + + -- Step 2: The subprogram renaming aliases the wrapper + + Rewrite (Name (N), New_Occurrence_Of (Wrap_Id, Loc)); + end Build_Class_Wide_Wrapper; + + ----------------------------- + -- Find_Suitable_Candidate -- + ----------------------------- + + procedure Find_Suitable_Candidate + (Prim_Op : out Entity_Id; + Is_CW_Prim : out Boolean) + is + Loc : constant Source_Ptr := Sloc (N); + + function Find_Primitive (Typ : Entity_Id) return Entity_Id; + -- Find a primitive subprogram of type Typ which matches the + -- profile of the renaming declaration. + + procedure Interpretation_Error (Subp_Id : Entity_Id); + -- Emit a continuation error message suggesting subprogram Subp_Id + -- as a possible interpretation. + + function Is_Intrinsic_Equality + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id denotes the intrinsic "=" + -- operator. + + function Is_Suitable_Candidate + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a suitable candidate + -- for the role of a wrapped subprogram. + + -------------------- + -- Find_Primitive -- + -------------------- + + function Find_Primitive (Typ : Entity_Id) return Entity_Id is + procedure Replace_Parameter_Types (Spec : Node_Id); + -- Given a specification Spec, replace all class-wide parameter + -- types with reference to type Typ. + + ----------------------------- + -- Replace_Parameter_Types -- + ----------------------------- + + procedure Replace_Parameter_Types (Spec : Node_Id) is + Formal : Node_Id; + Formal_Id : Entity_Id; + Formal_Typ : Node_Id; + + begin + Formal := First (Parameter_Specifications (Spec)); + while Present (Formal) loop + Formal_Id := Defining_Identifier (Formal); + Formal_Typ := Parameter_Type (Formal); + + -- Create a new entity for each class-wide formal to + -- prevent aliasing with the original renaming. Replace + -- the type of such a parameter with the candidate type. + + if Nkind (Formal_Typ) = N_Identifier + and then Is_Class_Wide_Type (Etype (Formal_Typ)) + then + Set_Defining_Identifier (Formal, + Make_Defining_Identifier (Loc, Chars (Formal_Id))); + + Set_Parameter_Type (Formal, + New_Occurrence_Of (Typ, Loc)); + end if; + + Next (Formal); + end loop; + end Replace_Parameter_Types; + + -- Local variables + + Alt_Ren : constant Node_Id := New_Copy_Tree (N); + Alt_Nam : constant Node_Id := Name (Alt_Ren); + Alt_Spec : constant Node_Id := Specification (Alt_Ren); + Subp_Id : Entity_Id; + + -- Start of processing for Find_Primitive + + begin + -- Each attempt to find a suitable primitive of a particular + -- type operates on its own copy of the original renaming. + -- As a result the original renaming is kept decoration and + -- side-effect free. + + -- Inherit the overloaded status of the renamed subprogram name + + if Is_Overloaded (Nam) then + Set_Is_Overloaded (Alt_Nam); + Save_Interps (Nam, Alt_Nam); + end if; + + -- The copied renaming is hidden from visibility to prevent the + -- pollution of the enclosing context. + + Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R')); + + -- The types of all class-wide parameters must be changed to + -- the candidate type. + + Replace_Parameter_Types (Alt_Spec); + + -- Try to find a suitable primitive that matches the altered + -- profile of the renaming specification. + + Subp_Id := + Find_Renamed_Entity + (N => Alt_Ren, + Nam => Name (Alt_Ren), + New_S => Analyze_Subprogram_Specification (Alt_Spec), + Is_Actual => Is_Actual); + + -- Do not return Any_Id if the resolution of the altered + -- profile failed as this complicates further checks on + -- the caller side; return Empty instead. + + if Subp_Id = Any_Id then + return Empty; + else + return Subp_Id; + end if; + end Find_Primitive; + + -------------------------- + -- Interpretation_Error -- + -------------------------- + + procedure Interpretation_Error (Subp_Id : Entity_Id) is + begin + Error_Msg_Sloc := Sloc (Subp_Id); + + if Is_Internal (Subp_Id) then + Error_Msg_NE + ("\\possible interpretation: predefined & #", + Spec, Formal_Spec); + else + Error_Msg_NE + ("\\possible interpretation: & defined #", + Spec, Formal_Spec); + end if; + end Interpretation_Error; + + --------------------------- + -- Is_Intrinsic_Equality -- + --------------------------- + + function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean + is + begin + return + Ekind (Subp_Id) = E_Operator + and then Chars (Subp_Id) = Name_Op_Eq + and then Is_Intrinsic_Subprogram (Subp_Id); + end Is_Intrinsic_Equality; + + --------------------------- + -- Is_Suitable_Candidate -- + --------------------------- + + function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean + is + begin + if No (Subp_Id) then + return False; + + -- An intrinsic subprogram is never a good candidate. This + -- is an indication of a missing primitive, either defined + -- directly or inherited from a parent tagged type. + + elsif Is_Intrinsic_Subprogram (Subp_Id) then + return False; + + else + return True; + end if; + end Is_Suitable_Candidate; + + -- Local variables + + Actual_Typ : Entity_Id := Empty; + -- The actual class-wide type for Formal_Typ + + CW_Prim_OK : Boolean; + CW_Prim_Op : Entity_Id; + -- The class-wide subprogram (if available) that corresponds to + -- the renamed generic formal subprogram. + + Formal_Typ : Entity_Id := Empty; + -- The generic formal type with unknown discriminants + + Root_Prim_OK : Boolean; + Root_Prim_Op : Entity_Id; + -- The root type primitive (if available) that corresponds to the + -- renamed generic formal subprogram. + + Root_Typ : Entity_Id := Empty; + -- The root type of Actual_Typ + + Formal : Node_Id; + + -- Start of processing for Find_Suitable_Candidate + + begin + pragma Assert (not Error_Posted (Nam)); + + Prim_Op := Empty; + Is_CW_Prim := False; + + -- Analyze the renamed name, but do not resolve it. The resolution + -- is completed once a suitable subprogram is found. + + Analyze (Nam); + + -- When the renamed name denotes the intrinsic operator equals, + -- the name must be treated as overloaded. This allows for a + -- potential match against the root type's predefined equality + -- function. + + if Is_Intrinsic_Equality (Entity (Nam)) then + Set_Is_Overloaded (Nam); + Collect_Interps (Nam); + end if; + + -- Step 1: Find the generic formal type and its corresponding + -- class-wide actual type from the renamed generic formal + -- subprogram. + + Formal := First_Formal (Formal_Spec); + while Present (Formal) loop + if Has_Unknown_Discriminants (Etype (Formal)) + and then not Is_Class_Wide_Type (Etype (Formal)) + and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) + then + Formal_Typ := Etype (Formal); + Actual_Typ := Base_Type (Get_Instance_Of (Formal_Typ)); + Root_Typ := Root_Type (Actual_Typ); + exit; + end if; + + Next_Formal (Formal); + end loop; + + -- The specification of the generic formal subprogram should + -- always contain a formal type with unknown discriminants whose + -- actual is a class-wide type; otherwise this indicates a failure + -- in function Has_Class_Wide_Actual. + + pragma Assert (Present (Formal_Typ)); + + -- Step 2: Find the proper class-wide subprogram or primitive + -- that corresponds to the renamed generic formal subprogram. + + CW_Prim_Op := Find_Primitive (Actual_Typ); + CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); + Root_Prim_Op := Find_Primitive (Root_Typ); + Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); + + -- The class-wide actual type has two subprograms that correspond + -- to the renamed generic formal subprogram: + + -- with procedure Prim_Op (Param : Formal_Typ); + + -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited + -- procedure Prim_Op (Param : Actual_Typ'Class); + + -- Even though the declaration of the two subprograms is legal, a + -- call to either one is ambiguous and therefore illegal. + + if CW_Prim_OK and Root_Prim_OK then + + -- A user-defined primitive has precedence over a predefined + -- one. + + if Is_Internal (CW_Prim_Op) + and then not Is_Internal (Root_Prim_Op) + then + Prim_Op := Root_Prim_Op; + + elsif Is_Internal (Root_Prim_Op) + and then not Is_Internal (CW_Prim_Op) + then + Prim_Op := CW_Prim_Op; + Is_CW_Prim := True; + + elsif CW_Prim_Op = Root_Prim_Op then + Prim_Op := Root_Prim_Op; + + -- The two subprograms are legal but the class-wide subprogram + -- is a class-wide wrapper built for a previous instantiation; + -- the wrapper has precedence. + + elsif Present (Alias (CW_Prim_Op)) + and then Is_Class_Wide_Wrapper (Ultimate_Alias (CW_Prim_Op)) + then + Prim_Op := CW_Prim_Op; + Is_CW_Prim := True; + + -- Otherwise both candidate subprograms are user-defined and + -- ambiguous. + + else + Error_Msg_NE + ("ambiguous actual for generic subprogram &", + Spec, Formal_Spec); + Interpretation_Error (Root_Prim_Op); + Interpretation_Error (CW_Prim_Op); + return; + end if; + + elsif CW_Prim_OK and not Root_Prim_OK then + Prim_Op := CW_Prim_Op; + Is_CW_Prim := True; + + elsif not CW_Prim_OK and Root_Prim_OK then + Prim_Op := Root_Prim_Op; + + -- An intrinsic equality may act as a suitable candidate in the + -- case of a null type extension where the parent's equality + -- is hidden. A call to an intrinsic equality is expanded as + -- dispatching. + + elsif Present (Root_Prim_Op) + and then Is_Intrinsic_Equality (Root_Prim_Op) + then + Prim_Op := Root_Prim_Op; + + -- Otherwise there are no candidate subprograms. Let the caller + -- diagnose the error. + + else + return; + end if; + + -- At this point resolution has taken place and the name is no + -- longer overloaded. Mark the primitive as referenced. + + Set_Is_Overloaded (Name (N), False); + Set_Referenced (Prim_Op); + end Find_Suitable_Candidate; + + -- Local variables + + Is_CW_Prim : Boolean; + + -- Start of processing for Handle_Instance_With_Class_Wide_Type + + begin + Wrapped_Prim := Empty; + Wrap_Id := Empty; + + -- Ada 2012 (AI05-0071): A generic/instance scenario involving a + -- formal type with unknown discriminants and a generic primitive + -- operation of the said type with a box require special processing + -- when the actual is a class-wide type: + -- + -- generic + -- type Formal_Typ (<>) is private; + -- with procedure Prim_Op (Param : Formal_Typ) is <>; + -- package Gen is ... + -- + -- package Inst is new Gen (Actual_Typ'Class); + -- + -- In this case the general renaming mechanism used in the prologue + -- of an instance no longer applies: + -- + -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; + -- + -- The above is replaced the following wrapper/renaming combination: + -- + -- procedure Wrapper (Param : Formal_Typ) is -- wrapper + -- begin + -- Prim_Op (Param); -- primitive + -- end Wrapper; + -- + -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper; + -- + -- This transformation applies only if there is no explicit visible + -- class-wide operation at the point of the instantiation. Ren_Id is + -- the entity of the renaming declaration. When the transformation + -- applies, Wrapped_Prim is the entity of the wrapped primitive. + + if Box_Present (Inst_Node) then + Find_Suitable_Candidate + (Prim_Op => Wrapped_Prim, + Is_CW_Prim => Is_CW_Prim); + + if Present (Wrapped_Prim) then + if not Is_CW_Prim then + Build_Class_Wide_Wrapper (Ren_Id, Wrapped_Prim, Wrap_Id); + + -- Small optimization: When the candidate is a class-wide + -- subprogram we don't build the wrapper; we modify the + -- renaming declaration to directly map the actual to the + -- generic formal and discard the candidate. + + else + Rewrite (Nam, New_Occurrence_Of (Wrapped_Prim, Sloc (N))); + Wrapped_Prim := Empty; + end if; + end if; + + -- Ada 2022 (AI12-0165, RM 12.6(8.5/3)): The actual subprogram for a + -- formal_abstract_subprogram_declaration shall be: + -- a) a dispatching operation of the controlling type; or + -- b) if the controlling type is a formal type, and the actual + -- type corresponding to that formal type is a specific type T, + -- a dispatching operation of type T; or + -- c) if the controlling type is a formal type, and the actual + -- type is a class-wide type T'Class, an implicitly declared + -- subprogram corresponding to a primitive operation of type T. + + elsif Nkind (Inst_Node) = N_Formal_Abstract_Subprogram_Declaration + and then Is_Entity_Name (Nam) + then + Find_Suitable_Candidate + (Prim_Op => Wrapped_Prim, + Is_CW_Prim => Is_CW_Prim); + + if Present (Wrapped_Prim) then + + -- Cases (a) and (b); see previous description. + + if not Is_CW_Prim then + Build_Class_Wide_Wrapper (Ren_Id, Wrapped_Prim, Wrap_Id); + + -- Case (c); see previous description. + + -- Implicit operations of T'Class for subtype declarations + -- are built by Derive_Subprogram, and their Alias attribute + -- references the primitive operation of T. + + elsif not Comes_From_Source (Wrapped_Prim) + and then Nkind (Parent (Wrapped_Prim)) = N_Subtype_Declaration + and then Present (Alias (Wrapped_Prim)) + then + -- We don't need to build the wrapper; we modify the + -- renaming declaration to directly map the actual to + -- the generic formal and discard the candidate. + + Rewrite (Nam, + New_Occurrence_Of (Alias (Wrapped_Prim), Sloc (N))); + Wrapped_Prim := Empty; + + -- Legality rules do not apply; discard the candidate. + + else + Wrapped_Prim := Empty; + end if; + end if; + end if; + end Handle_Instance_With_Class_Wide_Type; + ------------------------- -- Original_Subprogram -- ------------------------- @@ -2965,12 +3094,13 @@ package body Sem_Ch8 is -- Local variables CW_Actual : constant Boolean := Has_Class_Wide_Actual; - -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a - -- defaulted formal subprogram when the actual for a related formal - -- type is class-wide. + -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if the + -- renaming is for a defaulted formal subprogram when the actual for a + -- related formal type is class-wide. - Inst_Node : Node_Id := Empty; - New_S : Entity_Id; + Inst_Node : Node_Id := Empty; + New_S : Entity_Id := Empty; + Wrapped_Prim : Entity_Id := Empty; -- Start of processing for Analyze_Subprogram_Renaming @@ -3101,11 +3231,64 @@ package body Sem_Ch8 is if Is_Actual then Inst_Node := Unit_Declaration_Node (Formal_Spec); - -- Check whether the renaming is for a defaulted actual subprogram - -- with a class-wide actual. + -- Ada 2012 (AI05-0071) and Ada 2022 (AI12-0165): when the actual + -- type is a class-wide type T'Class we may need to wrap a primitive + -- operation of T. Search for the wrapped primitive and (if required) + -- build a wrapper whose body consists of a dispatching call to the + -- wrapped primitive of T, with its formal parameters as the actual + -- parameters. - if CW_Actual and then Box_Present (Inst_Node) then - Build_Class_Wide_Wrapper (New_S, Old_S); + if CW_Actual and then + + -- Ada 2012 (AI05-0071): Check whether the renaming is for a + -- defaulted actual subprogram with a class-wide actual. + + (Box_Present (Inst_Node) + + or else + + -- Ada 2022 (AI12-0165): Check whether the renaming is for a formal + -- abstract subprogram declaration with a class-wide actual. + + (Nkind (Inst_Node) = N_Formal_Abstract_Subprogram_Declaration + and then Is_Entity_Name (Nam))) + then + New_S := Analyze_Subprogram_Specification (Spec); + + -- Do not attempt to build the wrapper if the renaming is in error + + if not Error_Posted (Nam) then + Handle_Instance_With_Class_Wide_Type + (Inst_Node => Inst_Node, + Ren_Id => New_S, + Wrapped_Prim => Wrapped_Prim, + Wrap_Id => Old_S); + + -- If several candidates were found, then we reported the + -- ambiguity; stop processing the renaming declaration to + -- avoid reporting further (spurious) errors. + + if Error_Posted (Spec) then + return; + end if; + + end if; + end if; + + if Present (Wrapped_Prim) then + + -- When the wrapper is built, the subprogram renaming aliases + -- the wrapper. + + Analyze (Nam); + + pragma Assert (Old_S = Entity (Nam) + and then Is_Class_Wide_Wrapper (Old_S)); + + -- The subprogram renaming declaration may become Ghost if it + -- renames a wrapper of a Ghost entity. + + Mark_Ghost_Renaming (N, Wrapped_Prim); elsif Is_Entity_Name (Nam) and then Present (Entity (Nam)) @@ -3685,7 +3868,15 @@ package body Sem_Ch8 is -- indicate that the renaming is an abstract dispatching operation -- with a controlling type. - if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then + -- Skip this decoration when the renaming corresponds to an + -- association with class-wide wrapper (see above) because such + -- wrapper is neither abstract nor a dispatching operation (its + -- body has the dispatching call to the wrapped primitive). + + if Is_Actual + and then Is_Abstract_Subprogram (Formal_Spec) + and then No (Wrapped_Prim) + then -- Mark the renaming as abstract here, so Find_Dispatching_Type -- see it as corresponding to a generic association for a @@ -5008,9 +5199,9 @@ package body Sem_Ch8 is Next_Entity (Id); end loop; - if Present (Renamed_Object (Pack)) then - Set_In_Use (Renamed_Object (Pack), False); - Set_Current_Use_Clause (Renamed_Object (Pack), Empty); + if Present (Renamed_Entity (Pack)) then + Set_In_Use (Renamed_Entity (Pack), False); + Set_Current_Use_Clause (Renamed_Entity (Pack), Empty); end if; if Chars (Pack) = Name_System @@ -5224,8 +5415,8 @@ package body Sem_Ch8 is ------------------------ function Declared_In_Actual (Pack : Entity_Id) return Boolean is + pragma Assert (Ekind (Pack) = E_Package); Act : Entity_Id; - begin if No (Associated_Formal_Package (Pack)) then return False; @@ -5233,13 +5424,13 @@ package body Sem_Ch8 is else Act := First_Entity (Pack); while Present (Act) loop - if Renamed_Object (Pack) = Scop then + if Renamed_Entity (Pack) = Scop then return True; -- Check for end of list of actuals elsif Ekind (Act) = E_Package - and then Renamed_Object (Act) = Pack + and then Renamed_Entity (Act) = Pack then return False; @@ -6056,9 +6247,9 @@ package body Sem_Ch8 is if Scope (E) = Scope (E2) and then Ekind (E) = E_Package - and then Present (Renamed_Object (E)) - and then Is_Generic_Instance (Renamed_Object (E)) - and then In_Open_Scopes (Renamed_Object (E)) + and then Present (Renamed_Entity (E)) + and then Is_Generic_Instance (Renamed_Entity (E)) + and then In_Open_Scopes (Renamed_Entity (E)) and then Comes_From_Source (N) then Set_Is_Immediately_Visible (E, False); @@ -6389,9 +6580,9 @@ package body Sem_Ch8 is -- original package. if Ekind (P_Name) = E_Package - and then Present (Renamed_Object (P_Name)) + and then Present (Renamed_Entity (P_Name)) then - P_Name := Renamed_Object (P_Name); + P_Name := Renamed_Entity (P_Name); if From_Limited_With (P_Name) and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) @@ -7196,9 +7387,9 @@ package body Sem_Ch8 is Scop := Entity (Prefix (Nam)); if Ekind (Scop) = E_Package - and then Present (Renamed_Object (Scop)) + and then Present (Renamed_Entity (Scop)) then - Scop := Renamed_Object (Scop); + Scop := Renamed_Entity (Scop); end if; -- Operator is visible if prefix of expanded name denotes @@ -7279,8 +7470,10 @@ package body Sem_Ch8 is if Within (It.Nam, Inst) then if Within (Old_S, Inst) then declare - It_D : constant Uint := Scope_Depth (It.Nam); - Old_D : constant Uint := Scope_Depth (Old_S); + It_D : constant Uint := + Scope_Depth_Default_0 (It.Nam); + Old_D : constant Uint := + Scope_Depth_Default_0 (Old_S); N_Ent : Entity_Id; begin -- Choose the innermost subprogram, which @@ -9043,7 +9236,7 @@ package body Sem_Ch8 is if Ekind (S) = E_Void then null; - -- Set scope depth if not a non-concurrent type, and we have not yet set + -- Set scope depth if not a nonconcurrent type, and we have not yet set -- the scope depth. This means that we have the first occurrence of the -- scope, and this is where the depth is set. @@ -9057,10 +9250,12 @@ package body Sem_Ch8 is Set_Scope_Depth_Value (S, Uint_1); elsif not Is_Record_Type (Current_Scope) then - if Ekind (S) = E_Loop then - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); - else - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + if Scope_Depth_Set (Current_Scope) then + if Ekind (S) = E_Loop then + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); + else + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + end if; end if; end if; end if; @@ -9878,8 +10073,8 @@ package body Sem_Ch8 is -- When a renaming exists we must check it for redundancy. The -- original package would have already been seen at this point. - if Present (Renamed_Object (Entity (Pack_Name))) then - P := Renamed_Object (Entity (Pack_Name)); + if Present (Renamed_Entity (Entity (Pack_Name))) then + P := Renamed_Entity (Entity (Pack_Name)); else P := Entity (Pack_Name); end if; @@ -9945,10 +10140,10 @@ package body Sem_Ch8 is -- also in use (the flags on both entities must remain consistent, and a -- subsequent use of either of them should be recognized as redundant). - if Present (Renamed_Object (P)) then - Set_In_Use (Renamed_Object (P)); - Set_Current_Use_Clause (Renamed_Object (P), N); - Real_P := Renamed_Object (P); + if Present (Renamed_Entity (P)) then + Set_In_Use (Renamed_Entity (P)); + Set_Current_Use_Clause (Renamed_Entity (P), N); + Real_P := Renamed_Entity (P); else Real_P := P; end if; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 122a837..c906708 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1308,15 +1308,11 @@ package body Sem_Elab is -- is set, then string " in SPARK" is added to the end of the message. procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); + (Ref : Node_Id; + Var_Id : Entity_Id); pragma Inline (Info_Variable_Reference); -- Output information concerning reference Ref which mentions variable - -- Var_Id. If flag Info_Msg is set, the routine emits an information - -- message, otherwise it emits an error. If flag In_SPARK is set, then - -- string " in SPARK" is added to the end of the message. + -- Var_Id. The routine emits an error suffixed with " in SPARK". end Diagnostics; use Diagnostics; @@ -3036,11 +3032,9 @@ package body Sem_Elab is pragma Inline (Nested_Scenarios); -- Obtain the list of scenarios associated with subprogram body N - procedure Set_Is_Traversed_Body - (N : Node_Id; - Val : Boolean := True); + procedure Set_Is_Traversed_Body (N : Node_Id); pragma Inline (Set_Is_Traversed_Body); - -- Mark subprogram body N as traversed depending on value Val + -- Mark subprogram body N as traversed procedure Set_Nested_Scenarios (N : Node_Id; @@ -3105,18 +3099,11 @@ package body Sem_Elab is -- Set_Is_Traversed_Body -- --------------------------- - procedure Set_Is_Traversed_Body - (N : Node_Id; - Val : Boolean := True) - is + procedure Set_Is_Traversed_Body (N : Node_Id) is pragma Assert (Present (N)); begin - if Val then - NE_Set.Insert (Traversed_Bodies_Set, N); - else - NE_Set.Delete (Traversed_Bodies_Set, N); - end if; + NE_Set.Insert (Traversed_Bodies_Set, N); end Set_Is_Traversed_Body; -------------------------- @@ -3828,14 +3815,14 @@ package body Sem_Elab is ----------------------- function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is + pragma Assert (Ekind (Var_Id) = E_Variable); Ren_Id : Entity_Id; - begin Ren_Id := Var_Id; - while Present (Renamed_Entity (Ren_Id)) - and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity + while Present (Renamed_Object (Ren_Id)) + and then Nkind (Renamed_Object (Ren_Id)) in N_Entity loop - Ren_Id := Renamed_Entity (Ren_Id); + Ren_Id := Renamed_Object (Ren_Id); end loop; return Ren_Id; @@ -6697,10 +6684,8 @@ package body Sem_Elab is ----------------------------- procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) + (Ref : Node_Id; + Var_Id : Entity_Id) is begin if Is_Read (Ref) then @@ -6708,8 +6693,8 @@ package body Sem_Elab is (Msg => "read of variable & during elaboration", N => Ref, Id => Var_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); + Info_Msg => False, + In_SPARK => True); end if; end Info_Variable_Reference; end Diagnostics; @@ -8638,10 +8623,8 @@ package body Sem_Elab is elsif Is_Suitable_Variable_Reference (N) then Info_Variable_Reference - (Ref => N, - Var_Id => Targ_Id, - Info_Msg => False, - In_SPARK => True); + (Ref => N, + Var_Id => Targ_Id); -- No other scenario may impose a requirement on the context of -- the main unit. @@ -11805,19 +11788,15 @@ package body Sem_Elab is -- by creating an entry for it in the ALI file of the main unit. Formal -- In_State denotes the current state of the Processing phase. - procedure Set_Is_Saved_Construct - (Constr : Entity_Id; - Val : Boolean := True); + procedure Set_Is_Saved_Construct (Constr : Entity_Id); pragma Inline (Set_Is_Saved_Construct); -- Mark invocation construct Constr as declared in the ALI file of the - -- main unit depending on value Val. + -- main unit. - procedure Set_Is_Saved_Relation - (Rel : Invoker_Target_Relation; - Val : Boolean := True); + procedure Set_Is_Saved_Relation (Rel : Invoker_Target_Relation); pragma Inline (Set_Is_Saved_Relation); -- Mark simple invocation relation Rel as recorded in the ALI file of - -- the main unit depending on value Val. + -- the main unit. function Target_Of (Pos : Active_Scenario_Pos; @@ -13307,34 +13286,20 @@ package body Sem_Elab is -- Set_Is_Saved_Construct -- ---------------------------- - procedure Set_Is_Saved_Construct - (Constr : Entity_Id; - Val : Boolean := True) - is + procedure Set_Is_Saved_Construct (Constr : Entity_Id) is pragma Assert (Present (Constr)); begin - if Val then - NE_Set.Insert (Saved_Constructs_Set, Constr); - else - NE_Set.Delete (Saved_Constructs_Set, Constr); - end if; + NE_Set.Insert (Saved_Constructs_Set, Constr); end Set_Is_Saved_Construct; --------------------------- -- Set_Is_Saved_Relation -- --------------------------- - procedure Set_Is_Saved_Relation - (Rel : Invoker_Target_Relation; - Val : Boolean := True) - is + procedure Set_Is_Saved_Relation (Rel : Invoker_Target_Relation) is begin - if Val then - IR_Set.Insert (Saved_Relations_Set, Rel); - else - IR_Set.Delete (Saved_Relations_Set, Rel); - end if; + IR_Set.Insert (Saved_Relations_Set, Rel); end Set_Is_Saved_Relation; ------------------ diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 20bc03a..7270172 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -523,8 +523,8 @@ package body Sem_Eval is and then Nkind (Parent (N)) in N_Subexpr then Rewrite (N, New_Copy (N)); - Set_Realval - (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); + Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N)); + Set_Is_Machine_Number (N); end if; end if; @@ -575,18 +575,7 @@ package body Sem_Eval is (N, Corresponding_Integer_Value (N) * Small_Value (T)); elsif not UR_Is_Zero (Realval (N)) then - - -- Note: even though RM 4.9(38) specifies biased rounding, this - -- has been modified by AI-100 in order to prevent confusing - -- differences in rounding between static and non-static - -- expressions. AI-100 specifies that the effect of such rounding - -- is implementation dependent, and in GNAT we round to nearest - -- even to match the run-time behavior. Note that this applies - -- to floating point literals, not fixed points ones, even though - -- their compiler representation is also as a universal real. - - Set_Realval - (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); + Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N)); Set_Is_Machine_Number (N); end if; @@ -2845,7 +2834,7 @@ package body Sem_Eval is -- the expander that do not correspond to static expressions. procedure Eval_Integer_Literal (N : Node_Id) is - function In_Any_Integer_Context (Context : Node_Id) return Boolean; + function In_Any_Integer_Context (K : Node_Kind) return Boolean; -- If the literal is resolved with a specific type in a context where -- the expected type is Any_Integer, there are no range checks on the -- literal. By the time the literal is evaluated, it carries the type @@ -2856,23 +2845,21 @@ package body Sem_Eval is -- In_Any_Integer_Context -- ---------------------------- - function In_Any_Integer_Context (Context : Node_Id) return Boolean is + function In_Any_Integer_Context (K : Node_Kind) return Boolean is begin -- Any_Integer also appears in digits specifications for real types, -- but those have bounds smaller that those of any integer base type, -- so we can safely ignore these cases. - return - Nkind (Context) in N_Attribute_Definition_Clause - | N_Attribute_Reference - | N_Modular_Type_Definition - | N_Number_Declaration - | N_Signed_Integer_Type_Definition; + return K in N_Attribute_Definition_Clause + | N_Modular_Type_Definition + | N_Number_Declaration + | N_Signed_Integer_Type_Definition; end In_Any_Integer_Context; -- Local variables - Par : constant Node_Id := Parent (N); + PK : constant Node_Kind := Nkind (Parent (N)); Typ : constant Entity_Id := Etype (N); -- Start of processing for Eval_Integer_Literal @@ -2890,12 +2877,11 @@ package body Sem_Eval is -- Check_Non_Static_Context on an expanded literal may lead to spurious -- and misleading warnings. - if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression - or else Nkind (Par) not in N_Subexpr) - and then (Nkind (Par) not in N_Case_Expression_Alternative - | N_If_Expression - or else Comes_From_Source (N)) - and then not In_Any_Integer_Context (Par) + if (PK not in N_Subexpr + or else (PK in N_Case_Expression_Alternative | N_If_Expression + and then + Comes_From_Source (N))) + and then not In_Any_Integer_Context (PK) then Check_Non_Static_Context (N); end if; @@ -4366,7 +4352,25 @@ package body Sem_Eval is Fold_Uint (N, Expr_Value (Operand), Stat); end if; - if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then + -- If the target is a static floating-point subtype, then its bounds + -- are machine numbers so we must consider the machine-rounded value. + + if Is_Floating_Point_Type (Target_Type) + and then Nkind (N) = N_Real_Literal + and then not Is_Machine_Number (N) + then + declare + Lo : constant Node_Id := Type_Low_Bound (Target_Type); + Hi : constant Node_Id := Type_High_Bound (Target_Type); + Valr : constant Ureal := + Machine_Number (Target_Type, Expr_Value_R (N), N); + begin + if Valr < Expr_Value_R (Lo) or else Valr > Expr_Value_R (Hi) then + Out_Of_Range (N); + end if; + end; + + elsif Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then Out_Of_Range (N); end if; end Eval_Type_Conversion; @@ -6049,6 +6053,27 @@ package body Sem_Eval is end Is_Statically_Unevaluated; -------------------- + -- Machine_Number -- + -------------------- + + -- Historical note: RM 4.9(38) originally specified biased rounding but + -- this has been modified by AI-268 to prevent confusing differences in + -- rounding between static and nonstatic expressions. This AI specifies + -- that the effect of such rounding is implementation-dependent instead, + -- and in GNAT we round to nearest even to match the run-time behavior. + -- Note that this applies to floating-point literals, not fixed-point + -- ones, even though their representation is also a universal real. + + function Machine_Number + (Typ : Entity_Id; + Val : Ureal; + N : Node_Id) return Ureal + is + begin + return Machine (Typ, Val, Round_Even, N); + end Machine_Number; + + -------------------- -- Not_Null_Range -- -------------------- @@ -7335,19 +7360,12 @@ package body Sem_Eval is elsif Compile_Time_Known_Value (N) then declare - Lo : Node_Id; - Hi : Node_Id; - - LB_Known : Boolean; - HB_Known : Boolean; + Lo : constant Node_Id := Type_Low_Bound (Typ); + Hi : constant Node_Id := Type_High_Bound (Typ); + LB_Known : constant Boolean := Compile_Time_Known_Value (Lo); + HB_Known : constant Boolean := Compile_Time_Known_Value (Hi); begin - Lo := Type_Low_Bound (Typ); - Hi := Type_High_Bound (Typ); - - LB_Known := Compile_Time_Known_Value (Lo); - HB_Known := Compile_Time_Known_Value (Hi); - -- Fixed point types should be considered as such only if flag -- Fixed_Int is set to False. diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 5e1c2cb..c2e08b6 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -149,10 +149,9 @@ package Sem_Eval is -- -- Note: most cases of non-static context checks are handled within -- Sem_Eval itself, including all cases of expressions at the outer level - -- (i.e. those that are not a subexpression). Currently the only outside - -- customer for this procedure is Sem_Attr (because Eval_Attribute is - -- there). There is also one special case arising from ranges (see body of - -- Resolve_Range). + -- (i.e. those that are not a subexpression). The outside customers for + -- this procedure are Sem_Aggr, Sem_Attr (because Eval_Attribute is there) + -- and Sem_Res (for a special case arising from ranges, see Resolve_Range). -- -- Note: this procedure is also called by GNATprove on real literals -- that are not sub-expressions of static expressions, to convert them to @@ -487,6 +486,13 @@ package Sem_Eval is -- it cannot be determined at compile time. Flag Fixed_Int is used as in -- routine Is_In_Range above. + function Machine_Number + (Typ : Entity_Id; + Val : Ureal; + N : Node_Id) return Ureal; + -- Return the machine number of Typ corresponding to the specified Val as + -- per RM 4.9(38/2). N is a node only used to post warnings. + function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean; -- Returns True if it can guarantee that Lo .. Hi is not a null range. If -- it cannot (because the value of Lo or Hi is not known at compile time) @@ -575,5 +581,6 @@ private pragma Inline (Eval_Unchecked_Conversion); pragma Inline (Is_OK_Static_Expression); + pragma Inline (Machine_Number); end Sem_Eval; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0163ff9..10ad82f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4144,8 +4144,10 @@ package body Sem_Prag is -- than library level instantiations these can appear in contexts which -- would normally be invalid (they only apply to the original template -- and to library level instantiations), and they are simply ignored, - -- which is implemented by rewriting them as null statements and raising - -- exception to terminate analysis. + -- which is implemented by rewriting them as null statements and + -- optionally raising Pragma_Exit to terminate analysis. An exception + -- is not always raised to avoid exception propagation during the + -- bootstrap, so all callers should check whether N has been rewritten. procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); -- Check an Unchecked_Union variant for lack of nested variants and @@ -6652,8 +6654,14 @@ package body Sem_Prag is Sindex := Source_Index (Current_Sem_Unit); if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then + -- We do not want to raise an exception here since this code + -- is part of the bootstrap path where we cannot rely on + -- exception proapgation working. + -- Instead the caller should check for N being rewritten as + -- a null statement. + -- This code triggers when compiling a-except.adb. + Rewrite (N, Make_Null_Statement (Loc)); - raise Pragma_Exit; -- If before first declaration, the pragma applies to the -- enclosing unit, and the name if present must be this name. @@ -6678,9 +6686,7 @@ package body Sem_Prag is then Pragma_Misplaced; - elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration - or else Nkind (Parent_Node) = - N_Generic_Subprogram_Declaration) + elsif Nkind (Parent_Node) in N_Generic_Declaration and then Plist = Generic_Formal_Declarations (Parent_Node) then Pragma_Misplaced; @@ -12721,6 +12727,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Lib_Entity := Find_Lib_Unit_Name; -- A pragma that applies to a Ghost entity becomes Ghost for the @@ -15969,6 +15982,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); @@ -19652,6 +19672,13 @@ package body Sem_Prag is GNAT_Pragma; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + -- Must appear for a spec or generic spec if Nkind (Unit (Cunit (Current_Sem_Unit))) not in @@ -21438,6 +21465,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Ent := Find_Lib_Unit_Name; -- A pragma that applies to a Ghost entity becomes Ghost for the @@ -22074,8 +22108,15 @@ package body Sem_Prag is if Is_Wrapper_Package (Current_Scope) then return; - else - Check_Valid_Library_Unit_Pragma; + end if; + + Check_Valid_Library_Unit_Pragma; + + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; end if; Ent := Find_Lib_Unit_Name; @@ -22614,6 +22655,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Cunit_Node := Cunit (Current_Sem_Unit); K := Nkind (Unit (Cunit_Node)); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); @@ -22653,6 +22701,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); @@ -22849,6 +22904,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; + -- If N was rewritten as a null statement there is nothing more + -- to do. + + if Nkind (N) = N_Null_Statement then + return; + end if; + Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); @@ -31914,7 +31976,7 @@ package body Sem_Prag is Error_Msg_N ("condition is not known at compile time", Arg1x); elsif Warn_On_Unknown_Compile_Time_Warning then - Error_Msg_N ("??condition is not known at compile time", Arg1x); + Error_Msg_N ("?_c?condition is not known at compile time", Arg1x); end if; end Validate_Compile_Time_Warning_Or_Error; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0bdc463..09a76f1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -103,6 +103,14 @@ package body Sem_Res is -- Note that Resolve_Attribute is separated off in Sem_Attr + function Has_Applicable_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If N is a literal or a named number, check whether Typ + -- has a user-defined literal aspect that can apply to N. + -- If present, replace N with a call to the corresponding + -- function and return True. + procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining -- a component of a discriminated type (record or concurrent type). @@ -286,6 +294,15 @@ package body Sem_Res is -- is only one requires a search over all visible entities, and happens -- only in very pathological cases (see 6115-006). + function Try_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If an operator node has a literal operand, check whether the type + -- of the context, or the type of the other operand has a user-defined + -- literal aspect that can be applied to the literal to resolve the node. + -- If such aspect exists, replace literal with a call to the + -- corresponing function and return True, return false otherwise. + ------------------------- -- Ambiguous_Character -- ------------------------- @@ -409,6 +426,165 @@ package body Sem_Res is end if; end Analyze_And_Resolve; + ------------------------------------- + -- Has_Applicable_User_Defined_Literal -- + ------------------------------------- + + function Has_Applicable_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Literal_Aspect_Map : + constant array (N_Numeric_Or_String_Literal) of Aspect_Id := + (N_Integer_Literal => Aspect_Integer_Literal, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); + + Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := + (E_Named_Integer => Aspect_Integer_Literal, + E_Named_Real => Aspect_Real_Literal); + + Lit_Aspect : Aspect_Id; + + Callee : Entity_Id; + Name : Node_Id; + Param1 : Node_Id; + Param2 : Node_Id; + Params : List_Id; + Call : Node_Id; + Expr : Node_Id; + + begin + if (Nkind (N) in N_Numeric_Or_String_Literal + and then Present + (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) + or else + (Nkind (N) = N_Identifier + and then Is_Named_Number (Entity (N)) + and then + Present + (Find_Aspect + (Typ, Named_Number_Aspect_Map (Ekind (Entity (N)))))) + then + Lit_Aspect := + (if Nkind (N) = N_Identifier + then Named_Number_Aspect_Map (Ekind (Entity (N))) + else Literal_Aspect_Map (Nkind (N))); + Callee := + Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); + Name := Make_Identifier (Loc, Chars (Callee)); + + if Is_Derived_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Base_Type (Etype (Callee)) /= Base_Type (Typ) + then + Callee := + Corresponding_Primitive_Op + (Ancestor_Op => Callee, + Descendant_Type => Base_Type (Typ)); + end if; + + -- Handle an identifier that denotes a named number. + + if Nkind (N) = N_Identifier then + Expr := Expression (Declaration_Node (Entity (N))); + + if Ekind (Entity (N)) = E_Named_Integer then + UI_Image (Expr_Value (Expr), Decimal); + Start_String; + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param1 := Make_String_Literal (Loc, End_String); + Params := New_List (Param1); + + else + UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); + Start_String; + + if UR_Is_Negative (Expr_Value_R (Expr)) then + Store_String_Chars ("-"); + end if; + + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param1 := Make_String_Literal (Loc, End_String); + + -- Note: Set_Etype is called below on Param1 + + UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal); + Start_String; + Store_String_Chars + (UI_Image_Buffer (1 .. UI_Image_Length)); + Param2 := Make_String_Literal (Loc, End_String); + Set_Etype (Param2, Standard_String); + + Params := New_List (Param1, Param2); + + if Present (Related_Expression (Callee)) then + Callee := Related_Expression (Callee); + else + Error_Msg_NE + ("cannot resolve & for a named real", N, Callee); + return False; + end if; + end if; + + elsif Nkind (N) = N_String_Literal then + Param1 := Make_String_Literal (Loc, Strval (N)); + Params := New_List (Param1); + + else + Param1 := + Make_String_Literal + (Loc, String_From_Numeric_Literal (N)); + Params := New_List (Param1); + end if; + + Call := + Make_Function_Call + (Sloc => Loc, + Name => Name, + Parameter_Associations => Params); + + Set_Entity (Name, Callee); + Set_Is_Overloaded (Name, False); + + if Lit_Aspect = Aspect_String_Literal then + Set_Etype (Param1, Standard_Wide_Wide_String); + else + Set_Etype (Param1, Standard_String); + end if; + + Set_Etype (Call, Etype (Callee)); + + if Base_Type (Etype (Call)) /= Base_Type (Typ) then + -- Conversion may be needed in case of an inherited + -- aspect of a derived type. For a null extension, we + -- use a null extension aggregate instead because the + -- downward type conversion would be illegal. + + if Is_Null_Extension_Of + (Descendant => Typ, + Ancestor => Etype (Call)) + then + Call := Make_Extension_Aggregate (Loc, + Ancestor_Part => Call, + Null_Record_Present => True); + else + Call := Convert_To (Typ, Call); + end if; + end if; + + Rewrite (N, Call); + + Analyze_And_Resolve (N, Typ); + return True; + else + return False; + end if; + end Has_Applicable_User_Defined_Literal; + ---------------------------- -- Check_Discriminant_Use -- ---------------------------- @@ -2156,16 +2332,6 @@ package body Sem_Res is return; end Resolution_Failed; - Literal_Aspect_Map : - constant array (N_Numeric_Or_String_Literal) of Aspect_Id := - (N_Integer_Literal => Aspect_Integer_Literal, - N_Real_Literal => Aspect_Real_Literal, - N_String_Literal => Aspect_String_Literal); - - Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := - (E_Named_Integer => Aspect_Integer_Literal, - E_Named_Real => Aspect_Real_Literal); - -- Start of processing for Resolve begin @@ -2884,143 +3050,14 @@ package body Sem_Res is end; end if; - -- Rewrite Literal as a call if the corresponding literal aspect - -- is set. + -- If node is a literal and context type has a user-defined + -- literal aspect, rewrite node as a call to the corresponding + -- function, which plays the role of an implicit conversion. - if (Nkind (N) in N_Numeric_Or_String_Literal - and then - Present - (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) - or else - (Nkind (N) = N_Identifier - and then Is_Named_Number (Entity (N)) - and then - Present - (Find_Aspect - (Typ, Named_Number_Aspect_Map (Ekind (Entity (N)))))) + if Nkind (N) in + N_Numeric_Or_String_Literal | N_Identifier + and then Has_Applicable_User_Defined_Literal (N, Typ) then - declare - Lit_Aspect : constant Aspect_Id := - (if Nkind (N) = N_Identifier - then Named_Number_Aspect_Map (Ekind (Entity (N))) - else Literal_Aspect_Map (Nkind (N))); - - Loc : constant Source_Ptr := Sloc (N); - - Callee : Entity_Id := - Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); - - Name : constant Node_Id := - Make_Identifier (Loc, Chars (Callee)); - - Param1 : Node_Id; - Param2 : Node_Id; - Params : List_Id; - Call : Node_Id; - Expr : Node_Id; - - begin - if Is_Derived_Type (Typ) - and then Is_Tagged_Type (Typ) - and then Base_Type (Etype (Callee)) /= Base_Type (Typ) - then - Callee := - Corresponding_Primitive_Op - (Ancestor_Op => Callee, - Descendant_Type => Base_Type (Typ)); - end if; - - if Nkind (N) = N_Identifier then - Expr := Expression (Declaration_Node (Entity (N))); - - if Ekind (Entity (N)) = E_Named_Integer then - UI_Image (Expr_Value (Expr), Decimal); - Start_String; - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param1 := Make_String_Literal (Loc, End_String); - Params := New_List (Param1); - - else - UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal); - Start_String; - - if UR_Is_Negative (Expr_Value_R (Expr)) then - Store_String_Chars ("-"); - end if; - - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param1 := Make_String_Literal (Loc, End_String); - - -- Note: Set_Etype is called below on Param1 - - UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal); - Start_String; - Store_String_Chars - (UI_Image_Buffer (1 .. UI_Image_Length)); - Param2 := Make_String_Literal (Loc, End_String); - Set_Etype (Param2, Standard_String); - - Params := New_List (Param1, Param2); - - if Present (Related_Expression (Callee)) then - Callee := Related_Expression (Callee); - else - Error_Msg_NE - ("cannot resolve & for a named real", N, Callee); - return; - end if; - end if; - - elsif Nkind (N) = N_String_Literal then - Param1 := Make_String_Literal (Loc, Strval (N)); - Params := New_List (Param1); - else - Param1 := - Make_String_Literal - (Loc, String_From_Numeric_Literal (N)); - Params := New_List (Param1); - end if; - - Call := - Make_Function_Call - (Sloc => Loc, - Name => Name, - Parameter_Associations => Params); - - Set_Entity (Name, Callee); - Set_Is_Overloaded (Name, False); - - if Lit_Aspect = Aspect_String_Literal then - Set_Etype (Param1, Standard_Wide_Wide_String); - else - Set_Etype (Param1, Standard_String); - end if; - - Set_Etype (Call, Etype (Callee)); - - if Base_Type (Etype (Call)) /= Base_Type (Typ) then - -- Conversion may be needed in case of an inherited - -- aspect of a derived type. For a null extension, we - -- use a null extension aggregate instead because the - -- downward type conversion would be illegal. - - if Is_Null_Extension_Of - (Descendant => Typ, - Ancestor => Etype (Call)) - then - Call := Make_Extension_Aggregate (Loc, - Ancestor_Part => Call, - Null_Record_Present => True); - else - Call := Convert_To (Typ, Call); - end if; - end if; - - Rewrite (N, Call); - end; - Analyze_And_Resolve (N, Typ); return; end if; @@ -3116,6 +3153,14 @@ package body Sem_Res is ("missing ALL or SOME in quantified expression", Defining_Identifier (First (Component_Associations (N)))); + -- For an operator with no interpretation, check whether + -- one of its operands may be a user-defined literal. + + elsif Nkind (N) in N_Op + and then Try_User_Defined_Literal (N, Typ) + then + return; + else Wrong_Type (N, Typ); end if; @@ -3712,7 +3757,7 @@ package body Sem_Res is if Wrong_Order then Error_Msg_N - ("?P?actuals for this call may be in wrong order", N); + ("?.p?actuals for this call may be in wrong order", N); end if; end; end; @@ -7488,7 +7533,7 @@ package body Sem_Res is if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then Error_Msg_Sloc := Sloc (Etype (L)); Error_Msg_NE - ("comparison on unordered enumeration type& declared#?U?", + ("comparison on unordered enumeration type& declared#?.u?", N, Etype (L)); end if; @@ -10647,7 +10692,7 @@ package body Sem_Res is then Error_Msg_Sloc := Sloc (Typ); Error_Msg_NE - ("subrange of unordered enumeration type& declared#?U?", N, Typ); + ("subrange of unordered enumeration type& declared#?.u?", N, Typ); end if; Check_Unset_Reference (L); @@ -11163,7 +11208,7 @@ package body Sem_Res is -- of the First_Node call here. Error_Msg_F - ("?A?assertion would fail at run time!", + ("?.a?assertion would fail at run time!", Expression (First (Pragma_Argument_Associations (Orig)))); end if; @@ -11194,7 +11239,7 @@ package body Sem_Res is -- comment above for an explanation of why we do this. Error_Msg_F - ("?A?check would fail at run time!", + ("?.a?check would fail at run time!", Expression (Last (Pragma_Argument_Associations (Orig)))); end if; @@ -12185,7 +12230,7 @@ package body Sem_Res is and then Expr_Value (R) > Uint_1 then Error_Msg_N - ("?M?negative literal of modular type is in fact positive", N); + ("?.m?negative literal of modular type is in fact positive", N); Error_Msg_Uint_1 := (-Expr_Value (R)) mod Modulus (B_Typ); Error_Msg_Uint_2 := Expr_Value (R); Error_Msg_N ("\do you really mean^ when writing -^ '?", N); @@ -12847,6 +12892,76 @@ package body Sem_Res is end if; end Simplify_Type_Conversion; + ------------------------------ + -- Try_User_Defined_Literal -- + ------------------------------ + + function Try_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + if Nkind (N) in N_Op_Add | N_Op_Divide | N_Op_Mod | N_Op_Multiply + | N_Op_Rem | N_Op_Subtract + then + + -- Both operands must have the same type as the context. + -- (ignoring for now fixed-point and exponentiation ops). + + if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then + Resolve (Left_Opnd (N), Typ); + Analyze_And_Resolve (N, Typ); + return True; + end if; + + if + Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + then + Resolve (Right_Opnd (N), Typ); + Analyze_And_Resolve (N, Typ); + return True; + + else + return False; + end if; + + elsif Nkind (N) in N_Binary_Op then + -- For other operators the context does not impose a type on + -- the operands, but their types must match. + + if (Nkind (Left_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + and then + Has_Applicable_User_Defined_Literal + (Right_Opnd (N), Etype (Left_Opnd (N))) + then + Analyze_And_Resolve (N, Typ); + return True; + + elsif (Nkind (Right_Opnd (N)) + not in N_Integer_Literal | N_String_Literal | N_Real_Literal) + and then + Has_Applicable_User_Defined_Literal + (Left_Opnd (N), Etype (Right_Opnd (N))) + then + Analyze_And_Resolve (N, Typ); + return True; + else + return False; + end if; + + elsif Nkind (N) in N_Unary_Op + and then + Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + then + Analyze_And_Resolve (N, Typ); + return True; + + else -- Other operators + return False; + end if; + end Try_User_Defined_Literal; + ----------------------------- -- Unique_Fixed_Point_Type -- ----------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b5f3d4c..7240681 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -315,7 +315,8 @@ package body Sem_Util is -- Ignore transient scopes made during expansion if Comes_From_Source (Node_Par) then - return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; + return + Scope_Depth_Default_0 (Encl_Scop) + Master_Lvl_Modifier; end if; -- For a return statement within a function, return @@ -627,9 +628,9 @@ package body Sem_Util is -- caller. if Is_Explicitly_Aliased (E) - and then Level /= Dynamic_Level - and then (In_Return_Value (Expr) - or else In_Return_Context) + and then (In_Return_Context + or else (Level /= Dynamic_Level + and then In_Return_Value (Expr))) then return Make_Level_Literal (Scope_Depth (Standard_Standard)); @@ -722,17 +723,11 @@ package body Sem_Util is -- Note: We check if the original node of the renaming comes -- from source because the node may have been rewritten. - elsif Present (Renamed_Object (E)) - and then Comes_From_Source (Original_Node (Renamed_Object (E))) - then - return Accessibility_Level (Renamed_Object (E)); - - -- Move up renamed entities - - elsif Present (Renamed_Entity (E)) - and then Comes_From_Source (Original_Node (Renamed_Entity (E))) + elsif Present (Renamed_Entity_Or_Object (E)) + and then Comes_From_Source + (Original_Node (Renamed_Entity_Or_Object (E))) then - return Accessibility_Level (Renamed_Entity (E)); + return Accessibility_Level (Renamed_Entity_Or_Object (E)); -- Named access types get their level from their associated type @@ -1137,6 +1132,10 @@ package body Sem_Util is function Addressable (V : Uint) return Boolean is begin + if No (V) then + return False; + end if; + return V = Uint_8 or else V = Uint_16 or else V = Uint_32 or else @@ -4855,17 +4854,17 @@ package body Sem_Util is if Pragma_Name (Prag) = Name_Contract_Cases then Error_Msg_NE (Adjust_Message ("contract case does not check the outcome of calling " - & "&?T?"), Expr, Subp_Id); + & "&?.t?"), Expr, Subp_Id); elsif Pragma_Name (Prag) = Name_Refined_Post then Error_Msg_NE (Adjust_Message ("refined postcondition does not check the outcome of " - & "calling &?T?"), Err_Node, Subp_Id); + & "calling &?.t?"), Err_Node, Subp_Id); else Error_Msg_NE (Adjust_Message ("postcondition does not check the outcome of calling " - & "&?T?"), Err_Node, Subp_Id); + & "&?.t?"), Err_Node, Subp_Id); end if; end if; end Check_Conjunct; @@ -5133,20 +5132,20 @@ package body Sem_Util is then Error_Msg_N ("neither postcondition nor contract cases mention function " - & "result?T?", Post_Prag); + & "result?.t?", Post_Prag); -- The function has contract cases only and they do not mention -- attribute 'Result. elsif Present (Case_Prag) and then not Seen_In_Case then - Error_Msg_N ("contract cases do not mention result?T?", Case_Prag); + Error_Msg_N ("contract cases do not mention result?.t?", Case_Prag); -- The function has postconditions only and they do not mention -- attribute 'Result. elsif Present (Post_Prag) and then not Seen_In_Post then Error_Msg_N - ("postcondition does not mention function result?T?", Post_Prag); + ("postcondition does not mention function result?.t?", Post_Prag); end if; end Check_Result_And_Post_State; @@ -6589,11 +6588,14 @@ package body Sem_Util is if Inside_Init_Proc then declare + Init_Proc_Type : constant Entity_Id := + Etype (First_Formal (Current_Scope_No_Loops)); + Conc_Typ : constant Entity_Id := - Corresponding_Concurrent_Type - (Entity (Parameter_Type (First - (Parameter_Specifications - (Parent (Current_Scope)))))); + (if Present (Init_Proc_Type) + and then Init_Proc_Type in E_Record_Type_Id + then Corresponding_Concurrent_Type (Init_Proc_Type) + else Empty); begin -- Don't complain if the corresponding concurrent type @@ -7361,7 +7363,7 @@ package body Sem_Util is function Is_Valid_Renaming (N : Node_Id) return Boolean is begin if Is_Object_Renaming (N) - and then not Is_Valid_Renaming (Renamed_Entity (Entity (N))) + and then not Is_Valid_Renaming (Renamed_Object (Entity (N))) then return False; end if; @@ -7553,12 +7555,12 @@ package body Sem_Util is elsif Is_Object_Renaming (A1) and then Is_Valid_Renaming (A1) then - return Denotes_Same_Object (Renamed_Entity (Entity (A1)), A2); + return Denotes_Same_Object (Renamed_Object (Entity (A1)), A2); elsif Is_Object_Renaming (A2) and then Is_Valid_Renaming (A2) then - return Denotes_Same_Object (A1, Renamed_Entity (Entity (A2))); + return Denotes_Same_Object (A1, Renamed_Object (Entity (A2))); else return False; @@ -8027,8 +8029,7 @@ package body Sem_Util is if Present (Spec_Id) and then Nkind (Unit_Declaration_Node (Spec_Id)) in - N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration + N_Generic_Declaration then return Par; end if; @@ -8052,9 +8053,7 @@ package body Sem_Util is begin Par := Parent (N); while Present (Par) loop - if Nkind (Par) in N_Generic_Package_Declaration - | N_Generic_Subprogram_Declaration - then + if Nkind (Par) in N_Generic_Declaration then return Par; elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then @@ -8063,9 +8062,7 @@ package body Sem_Util is if Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); - if Nkind (Spec_Decl) in N_Generic_Package_Declaration - | N_Generic_Subprogram_Declaration - then + if Nkind (Spec_Decl) in N_Generic_Declaration then return Spec_Decl; end if; end if; @@ -10885,8 +10882,8 @@ package body Sem_Util is function Get_Generic_Entity (N : Node_Id) return Entity_Id is Ent : constant Entity_Id := Entity (Name (N)); begin - if Present (Renamed_Object (Ent)) then - return Renamed_Object (Ent); + if Present (Renamed_Entity (Ent)) then + return Renamed_Entity (Ent); else return Ent; end if; @@ -11403,10 +11400,8 @@ package body Sem_Util is ------------------------ function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is - R : Entity_Id; - + R : Entity_Id := E; begin - R := E; while Present (Renamed_Entity (R)) loop R := Renamed_Entity (R); end loop; @@ -16641,7 +16636,8 @@ package body Sem_Util is -- Predicate_Failure aspect, for which we do not construct a -- wrapper procedure. The subtype will be replaced by the -- expression being tested when the corresponding predicate - -- check is expanded. + -- check is expanded. It may also appear in the pragma Predicate + -- expression during legality checking. elsif Nkind (P) = N_Aspect_Specification and then Nkind (Parent (P)) = N_Subtype_Declaration @@ -16649,7 +16645,8 @@ package body Sem_Util is return True; elsif Nkind (P) = N_Pragma - and then Get_Pragma_Id (P) = Pragma_Predicate_Failure + and then Get_Pragma_Id (P) in Pragma_Predicate + | Pragma_Predicate_Failure then return True; end if; @@ -17888,9 +17885,7 @@ package body Sem_Util is -- a generic body modifies the Ekind of its spec to allow for recursive -- calls. - return - Nkind (Spec_Decl) in N_Generic_Package_Declaration - | N_Generic_Subprogram_Declaration; + return Nkind (Spec_Decl) in N_Generic_Declaration; end Is_Generic_Declaration_Or_Body; --------------------------- @@ -23118,7 +23113,7 @@ package body Sem_Util is -- types. elsif Is_Access_Type (Typ) - or else (Consider_IS_NS and then (Is_Scalar_Type (Typ))) + or else (Consider_IS_NS and then Is_Scalar_Type (Typ)) then return True; @@ -24094,7 +24089,8 @@ package body Sem_Util is -- declaration. elsif Nkind (N) = N_Object_Renaming_Declaration then - Set_Renamed_Object (Defining_Entity (Result), Name (Result)); + Set_Renamed_Object_Of_Possibly_Void + (Defining_Entity (Result), Name (Result)); -- Update the First_Real_Statement attribute of a replicated -- handled sequence of statements. diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 9e337f9..d9d5d95 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2408,12 +2408,12 @@ package body Sem_Warn is E1 := First_Entity (P); while Present (E1) loop - if Ekind (E1) = E_Package and then Renamed_Object (E1) = L then + if Ekind (E1) = E_Package and then Renamed_Entity (E1) = L then Is_Visible_Renaming := not Is_Hidden (E1); return E1; elsif Ekind (E1) = E_Package - and then No (Renamed_Object (E1)) + and then No (Renamed_Entity (E1)) and then not Is_Generic_Instance (E1) then R := Find_Package_Renaming (E1, L); @@ -3293,21 +3293,21 @@ package body Sem_Warn is elsif Warnings_Off_Used_Unmodified (E) then Error_Msg_NE - ("?W?could use Unmodified instead of " + ("?.w?could use Unmodified instead of " & "Warnings Off for &", Pragma_Identifier (N), E); -- Used only in context where Unreferenced would have worked elsif Warnings_Off_Used_Unreferenced (E) then Error_Msg_NE - ("?W?could use Unreferenced instead of " + ("?.w?could use Unreferenced instead of " & "Warnings Off for &", Pragma_Identifier (N), E); -- Not used at all else Error_Msg_NE - ("?W?pragma Warnings Off for & unused, " + ("?.w?pragma Warnings Off for & unused, " & "could be omitted", N, E); end if; end; @@ -3863,7 +3863,7 @@ package body Sem_Warn is -- This is one of the messages Error_Msg_FE - ("<I<writable actual for & overlaps with actual for &", + ("<.i<writable actual for & overlaps with actual for &", Act1, Form1); end if; end if; @@ -4220,11 +4220,11 @@ package body Sem_Warn is if Nkind (Par) = N_Op_Eq then Error_Msg_N ("suspicious equality test with modified version of " - & "same object?T?", Par); + & "same object?.t?", Par); else Error_Msg_N ("suspicious inequality test with modified version of " - & "same object?T?", Par); + & "same object?.t?", Par); end if; end if; end if; diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index cf0ecc1..ad8606f 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -189,13 +189,9 @@ package body Sinfo.Utils is ------------------ function End_Location (N : Node_Id) return Source_Ptr is - L : constant Uint := End_Span (N); + L : constant Valid_Uint := End_Span (N); begin - if No (L) then - return No_Location; - else - return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); - end if; + return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); end End_Location; -------------------- @@ -242,15 +238,28 @@ package body Sinfo.Utils is use Seinfo; function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is - (F_Kind in Node_Id_Field - | List_Id_Field - | Elist_Id_Field - | Name_Id_Field - | String_Id_Field - | Uint_Field - | Ureal_Field - | Union_Id_Field); -- True if the field type is one that can be converted to Types.Union_Id + (case F_Kind is + when Node_Id_Field + | List_Id_Field + | Elist_Id_Field + | Name_Id_Field + | String_Id_Field + | Valid_Uint_Field + | Unat_Field + | Upos_Field + | Nonzero_Uint_Field + | Uint_Field + | Ureal_Field + | Union_Id_Field => True, + when Flag_Field + | Node_Kind_Type_Field + | Entity_Kind_Type_Field + | Source_Ptr_Field + | Small_Paren_Count_Type_Field + | Convention_Id_Field + | Component_Alignment_Kind_Field + | Mechanism_Type_Field => False); ----------------------- -- Walk_Sinfo_Fields -- @@ -266,6 +275,8 @@ package body Sinfo.Utils is declare Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); + pragma Assert (Desc.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if Is_In_Union_Id (Desc.Kind) then Action (Get_Node_Field_Union (N, Desc.Offset)); @@ -291,6 +302,8 @@ package body Sinfo.Utils is declare Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); + pragma Assert (Desc.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if Is_In_Union_Id (Desc.Kind) then Set_Node_Field_Union diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 9b78ada..69996cb 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4394,7 +4394,12 @@ package body Sprint is when E_Modular_Integer_Type => Write_Header; Write_Str ("mod "); - Write_Uint_With_Col_Check (Modulus (Typ), Auto); + + if No (Modulus (Typ)) then + Write_Uint_With_Col_Check (Uint_0, Auto); + else + Write_Uint_With_Col_Check (Modulus (Typ), Auto); + end if; -- Floating-point types and subtypes diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index eb17865..5199e6d 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -312,11 +312,10 @@ package Tbuild is (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id; -- New_Occurrence_Of creates an N_Identifier node that is an occurrence of - -- the defining identifier Def_Id. The Entity and Etype of the result are - -- set from the given defining identifier as follows: Entity is a copy of - -- Def_Id. Etype is a copy of Def_Id for types, and a copy of the Etype of - -- Def_Id for other entities. Note that Is_Static_Expression is set if this - -- call creates an occurrence of an enumeration literal. + -- the defining identifier Def_Id. The Entity of the result is Def_Id. The + -- Etype of the result is Def_Id for types, and Etype (Def_Id) otherwise. + -- Is_Static_Expression is set if this call creates an occurrence of an + -- enumeration literal. function New_Suffixed_Name (Related_Id : Name_Id; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 4c7833b..aa06506 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -885,14 +885,13 @@ package body Treepr is Val : constant Uint := Get_Uint (N, FD.Offset); function Cast is new Unchecked_Conversion (Uint, Int); begin - -- Do this even if Val = No_Uint, because Uint fields default - -- to Uint_0. - - Print_Initial; - UI_Write (Val, Format); - Write_Str (" (Uint = "); - Write_Int (Cast (Val)); - Write_Char (')'); + if Present (Val) then + Print_Initial; + UI_Write (Val, Format); + Write_Str (" (Uint = "); + Write_Int (Cast (Val)); + Write_Char (')'); + end if; end; when Valid_Uint_Field | Unat_Field | Upos_Field @@ -1025,6 +1024,8 @@ package body Treepr is FD : Field_Descriptor; Format : UI_Format := Auto) is + pragma Assert (FD.Type_Only = No_Type_Only); + -- Type_Only is for entities begin if not Field_Is_Initial_Zero (N, Field) then Print_Field (Prefix, Image (Field), N, FD, Format); @@ -1042,9 +1043,10 @@ package body Treepr is FD : Field_Descriptor; Format : UI_Format := Auto) is + NN : constant Node_Id := Node_To_Fetch_From (N, Field); begin if not Field_Is_Initial_Zero (N, Field) then - Print_Field (Prefix, Image (Field), N, FD, Format); + Print_Field (Prefix, Image (Field), NN, FD, Format); end if; end Print_Entity_Field; @@ -1184,7 +1186,6 @@ package body Treepr is Prefix : constant String := Prefix_Str & Prefix_Char; Sfile : Source_File_Index; - Fmt : UI_Format; begin if Phase /= Printing then @@ -1400,12 +1401,6 @@ package body Treepr is end if; end if; - if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then - Fmt := Hex; - else - Fmt := Auto; - end if; - declare Fields : Node_Field_Array renames Node_Field_Table (Nkind (N)).all; Should_Print : constant Node_Field_Set := @@ -1440,6 +1435,12 @@ package body Treepr is => False, others => True); + + Fmt : constant UI_Format := + (if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) + then Hex + else Auto); + begin -- Outer loop makes flags come out last @@ -2054,25 +2055,16 @@ package body Treepr is New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2); -- Prefix string for printing referenced fields - procedure Visit_Descendant - (D : Union_Id; - No_Indent : Boolean := False); + procedure Visit_Descendant (D : Union_Id); -- This procedure tests the given value of one of the Fields referenced -- by the current node to determine whether to visit it recursively. - -- Normally No_Indent is false, which means that the visited node will - -- be indented using New_Prefix. If No_Indent is set to True, then - -- this indentation is skipped, and Prefix_Str is used for the call - -- to print the descendant. No_Indent is effective only if the - -- referenced descendant is a node. + -- The visited node will be indented using New_Prefix. ---------------------- -- Visit_Descendant -- ---------------------- - procedure Visit_Descendant - (D : Union_Id; - No_Indent : Boolean := False) - is + procedure Visit_Descendant (D : Union_Id) is begin -- Case of descendant is a node @@ -2145,11 +2137,7 @@ package body Treepr is -- execute a return if the node is not to be visited), we can -- go ahead and visit the node. - if No_Indent then - Visit_Node (Nod, Prefix_Str, Prefix_Char); - else - Visit_Node (Nod, New_Prefix, ' '); - end if; + Visit_Node (Nod, New_Prefix, ' '); end; -- Case of descendant is a list diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 2806e50..0938365 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -261,10 +261,10 @@ typedef Int String_Id; /* Type used for representation of universal integers. */ typedef Int Uint; -typedef Int Valid_Uint; -typedef Int Unat; -typedef Int Upos; -typedef Int Nonzero_Uint; +typedef Uint Valid_Uint; +typedef Uint Unat; +typedef Uint Upos; +typedef Uint Nonzero_Uint; /* Used to indicate missing Uint value. */ #define No_Uint Uint_Low_Bound diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 29d409b..06f6680 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -282,7 +282,10 @@ package body Uintp is -- value is returned from a correctness point of view. procedure Image_Char (C : Character); - -- Internal procedure to output one character + -- Output one character + + procedure Image_String (S : String); + -- Output characters procedure Image_Exponent (N : Natural); -- Output non-zero exponent. Note that we only use the exponent form in @@ -371,6 +374,17 @@ package body Uintp is Character'Val (Character'Pos ('0') + N mod 10); end Image_Exponent; + ------------------ + -- Image_String -- + ------------------ + + procedure Image_String (S : String) is + begin + for X of S loop + Image_Char (X); + end loop; + end Image_String; + ---------------- -- Image_Uint -- ---------------- @@ -401,7 +415,7 @@ package body Uintp is begin if No (Input) then - Image_Char ('?'); + Image_String ("No_Uint"); return; end if; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index d9f1f8f..08f6738 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -104,6 +104,7 @@ package Uintp is subtype Unat is Valid_Uint with Predicate => Unat >= Uint_0; -- natural subtype Upos is Valid_Uint with Predicate => Upos >= Uint_1; -- positive subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0; + subtype Unegative is Valid_Uint with Predicate => Unegative < Uint_0; subtype Ubool is Valid_Uint with Predicate => Ubool in Uint_0 | Uint_1; subtype Opt_Ubool is Uint with Predicate => No (Opt_Ubool) or else Opt_Ubool in Ubool; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index bca3527..207303b 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -557,6 +557,8 @@ begin "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & "order"); + Write_Line (" _p turn on warnings for pedantic checks"); + Write_Line (" _P turn off warnings for pedantic checks"); Write_Line (" q*+ turn on warnings for questionable " & "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & diff --git a/gcc/ada/vxworks7-cert-rtp-link.spec b/gcc/ada/vxworks7-cert-rtp-link.spec index 0e0440f..4bbf376 100644 --- a/gcc/ada/vxworks7-cert-rtp-link.spec +++ b/gcc/ada/vxworks7-cert-rtp-link.spec @@ -5,5 +5,6 @@ + %{!nostdlib:%{mrtp:%{!shared: \ -l:certRtp.o \ -L%:getenv(VSB_DIR /usr/lib/common/objcert) \ + --defsym=__wrs_rtp_base=0x80000000 \ -T%:getenv(VSB_DIR /usr/ldscripts/rtp.ld) \ }}} diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 912ceea..149e2fd 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -76,6 +76,7 @@ package body Warnsw is Warn_On_Overlap := Setting; Warn_On_Overridden_Size := Setting; Warn_On_Parameter_Order := Setting; + Warn_On_Pedantic_Checks := Setting; Warn_On_Questionable_Layout := Setting; Warn_On_Questionable_Missing_Parens := Setting; Warn_On_Record_Holes := Setting; @@ -172,6 +173,8 @@ package body Warnsw is W.Warn_On_Overridden_Size; Warn_On_Parameter_Order := W.Warn_On_Parameter_Order; + Warn_On_Pedantic_Checks := + W.Warn_On_Pedantic_Checks; Warn_On_Questionable_Layout := W.Warn_On_Questionable_Layout; Warn_On_Questionable_Missing_Parens := @@ -284,6 +287,8 @@ package body Warnsw is Warn_On_Overridden_Size; W.Warn_On_Parameter_Order := Warn_On_Parameter_Order; + W.Warn_On_Pedantic_Checks := + Warn_On_Pedantic_Checks; W.Warn_On_Questionable_Layout := Warn_On_Questionable_Layout; W.Warn_On_Questionable_Missing_Parens := @@ -505,6 +510,12 @@ package body Warnsw is when 'C' => Warn_On_Unknown_Compile_Time_Warning := False; + when 'p' => + Warn_On_Pedantic_Checks := True; + + when 'P' => + Warn_On_Pedantic_Checks := False; + when 'r' => Warn_On_Component_Order := True; diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 340a752..f58be1e 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -50,7 +50,8 @@ package Warnsw is Warn_On_Unknown_Compile_Time_Warning : Boolean := True; -- Warn on a pragma Compile_Time_Warning whose condition has a value that - -- is not known at compile time. + -- is not known at compile time. On by default, modified by use + -- of -gnatw_c/_C and set as part of -gnatwa. Warn_On_Overridden_Size : Boolean := False; -- Warn when explicit record component clause or array component_size @@ -58,6 +59,13 @@ package Warnsw is -- set with an explicit size clause. Off by default, modified by use of -- -gnatw.s/.S (but not -gnatwa). + Warn_On_Pedantic_Checks : Boolean := False; + -- Warn for violation of miscellaneous pedantic rules (such as when the + -- subtype of a formal parameter given in a subprogram body's specification + -- comes from a different subtype declaration that the subtype of the + -- formal in the subprogram declaration). Off by default, and set by + -- -gnatw_p (but not -gnatwa). + Warn_On_Questionable_Layout : Boolean := False; -- Warn when default layout of a record type is questionable for run-time -- efficiency reasons and would be improved by reordering the components. @@ -128,6 +136,7 @@ package Warnsw is Warn_On_Overlap : Boolean; Warn_On_Overridden_Size : Boolean; Warn_On_Parameter_Order : Boolean; + Warn_On_Pedantic_Checks : Boolean; Warn_On_Questionable_Layout : Boolean; Warn_On_Questionable_Missing_Parens : Boolean; Warn_On_Record_Holes : Boolean; |