diff options
| author | Martin Liska <mliska@suse.cz> | 2022-07-14 10:23:27 +0200 |
|---|---|---|
| committer | Martin Liska <mliska@suse.cz> | 2022-07-14 10:23:27 +0200 |
| commit | 2d4ba09d237b0a96caea98cb4e8a2ceb99d0d538 (patch) | |
| tree | a9bad20764f0b5fb830c6d4e57f58b3c2073ff6c | |
| parent | b9dc4e9c94877b52037f2bd4eb01b5d179e41a43 (diff) | |
| parent | 47725f78dc5788f6557ca851529ab6d7b74ca824 (diff) | |
| download | gcc-2d4ba09d237b0a96caea98cb4e8a2ceb99d0d538.zip gcc-2d4ba09d237b0a96caea98cb4e8a2ceb99d0d538.tar.gz gcc-2d4ba09d237b0a96caea98cb4e8a2ceb99d0d538.tar.bz2 | |
Merge branch 'master' into devel/sphinx
209 files changed, 7572 insertions, 2361 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 3db624b..b759cf4 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,86 @@ +2022-07-13 Aldy Hernandez <aldyh@redhat.com> + + * range-op.cc (operator_lt::fold_range): Use nonzero bits. + +2022-07-13 Aldy Hernandez <aldyh@redhat.com> + + * value-range.cc (irange::copy_to_legacy): Set nonzero mask. + (irange::legacy_intersect): Clear nonzero mask. + (irange::legacy_union): Same. + (irange::invert): Same. + +2022-07-13 Richard Biener <rguenther@suse.de> + + * tree-ssa-dom.h (record_temporary_equivalences): Remove. + * tree-ssa-dom.cc (dom_jt_state::m_blocks_on_stack): New. + (dom_jt_state::get_blocks_on_stack): Likewise. + (dom_opt_dom_walker::dom_opt_dom_walker): Take dom_jt_state. + (back_propagate_equivalences): Remove dominator bitmap + compute and instead use passed in m_blocks_on_stack. + (record_temporary_equivalences): Likewise. + (record_equivalences_from_incoming_edge): Likewise. + (dom_opt_dom_walker::before_dom_children): Maintain and + pass down blocks on stack. + (dom_opt_dom_walker::after_dom_children): Likewise. + +2022-07-13 Andrew Carlotti <andrew.carlotti@arm.com> + + * config/aarch64/aarch64-builtins.cc + (aarch64_general_gimple_fold_builtin): Add fixup for invalid GIMPLE. + +2022-07-13 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106249 + * tree-ssa-loop-manip.cc (tree_transform_and_unroll_loop): + Only verify LC SSA of the new_loop if we created it. + Use TODO_update_ssa_nophi for the SSA update after versioning + the loop. + +2022-07-12 Aldy Hernandez <aldyh@redhat.com> + + * range-op.cc (unsigned_singleton_p): Remove. + (operator_bitwise_and::remove_impossible_ranges): Remove. + (operator_bitwise_and::fold_range): Set nonzero bits. * + * value-range.cc (irange::get_nonzero_bits): Remove + legacy_mode_p assert. + (irange::dump_bitmasks): Remove legacy_mode_p check. + +2022-07-12 Richard Sandiford <richard.sandiford@arm.com> + + PR target/106253 + * predict.h (insn_optimization_type): Declare. + * predict.cc (insn_optimization_type): New function. + * internal-fn.def (IFN_ICEIL, IFN_IFLOOR, IFN_IRINT, IFN_IROUND) + (IFN_LCEIL, IFN_LFLOOR, IFN_LRINT, IFN_LROUND, IFN_LLCEIL) + (IFN_LLFLOOR, IFN_LLRINT, IFN_LLROUND): New internal functions. + * internal-fn.cc (unary_convert_direct): New macro. + (expand_convert_optab_fn): New function. + (expand_unary_convert_optab_fn): New macro. + (direct_unary_convert_optab_supported_p): Likewise. + * optabs.cc (expand_sfix_optab): Pass insn_optimization_type to + convert_optab_handler. + * config/aarch64/aarch64-protos.h + (aarch64_builtin_vectorized_function): Delete. + * config/aarch64/aarch64-builtins.cc + (aarch64_builtin_vectorized_function): Delete. + * config/aarch64/aarch64.cc + (TARGET_VECTORIZE_BUILTIN_VECTORIZED_FUNCTION): Delete. + * config/i386/i386.cc (ix86_optab_supported_p): Handle lround_optab. + * config/i386/i386.md (lround<X87MODEF:mode><SWI248x:mode>2): Remove + optimize_insn_for_size_p test. + +2022-07-12 Richard Biener <rguenther@suse.de> + + * tree-vect-loop-manip.cc (create_lcssa_for_virtual_phi): + Remove. + (vect_do_peeling): Do not call it, adjust comment. + +2022-07-12 Richard Sandiford <richard.sandiford@arm.com> + + * config/aarch64/aarch64-builtins.cc + (aarch64_builtin_vectorized_function): Remove handling of + floor, ceil, trunc, round, nearbyint, sqrt, clz and ctz. + 2022-07-11 Andrew MacLeod <amacleod@redhat.com> PR tree-optimization/106234 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 40dba6d..56754ca 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20220712 +20220714 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 02490f0..2469db4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,571 @@ +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (gnat_to_gnu) <N_Assignment_Statement>: Fix + a couple of minor issues in the commentary. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (gigi): Report a violation of No_Dependence + on System.Stack_Checking if Stack_Check_Probes_On_Target is not set + and -fstack-check is specified. + (build_binary_op_trapv): Report violatiosn of No_Dependence on both + System.Arith_64 and System.Arith_128. + (add_decl_expr): If an initialized variable, report a violation of + No_Dependence on System.Memory_Copy for large aggregate types. + (gnat_to_gnu) <N_Op_Eq>: Report a violation + of No_Dependence on System.Memory_Compare for large aggregate types. + <N_Assignment_Statement>! Report a violation of No_Dependence on + System.Memory_Set, System.Memory_Move or else System.Memory_Copy for + large aggregate types. + * gcc-interface/utils2.cc (maybe_wrap_malloc): Report a violation of + No_Dependence on System.Memory. + (maybe_wrap_free): Add GNAT_NODE parameter and report a violation of + No_Dependence on System.Memory. + (build_call_alloc_dealloc): Adjust call to maybe_wrap_free. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity): Do not set the debug + type for vector types. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Access_Subtype>: + Undo questionable renaming. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (Gigi_Cloned_Subtype): Handle private case. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (gigi): Add one more leading underscore to + name of stack checking function. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (Gigi_Cloned_Subtype): New function. + (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>: Call it to get the + cloned subtype, if any. + <E_Floating_Point_Subtype>: Likewise. + <E_Array_Subtype>: Likewise. + <E_Record_Subtype>: Likewise. + <E_Access_Subtype>: Likewise. + Deal with all cloned subtypes on the main path. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Access_Subtype>: Do + not reuse the TYPE_DECL of the base type. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.cc (gnat_pushdecl): Build DECL_ORIGINAL_TYPE + only for pointer types. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.cc (build_binary_op) <EQ_EXPR>: Also accept + pointer-to-function types that are not variant of each other. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.cc (unchecked_convert): Also pad in most cases + if the source is not a scalar type but the destination is. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Array_Type>: Save + and restore the alias set of the dummy pointer-to-array type. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * snames.ads-tmpl (Name_Memory_Compare): New package name. + (Name_Memory_Copy): Likewise. + (Name_Memory_Move): Likewise. + (Name_Memory_Set): Likewise. + +2022-07-13 Gary Dismukes <dismukes@adacore.com> + + * sem_ch13.adb (Check_And_Resolve_Storage_Model_Type_Argument): + Call the System.Case_Util.To_Mixed procedure rather than the + function, to avoid bootstrap problems. + +2022-07-13 Gary Dismukes <dismukes@adacore.com> + + * aspects.ads (Aspect_Argument): Change the association for + Aspect_Storage_Model_Type from Expression to + Optional_Expression. + * exp_util.ads (Find_Storage_Op): Update comment to indicate + that Empty can be returned in the case where a storage-model + operation is defaulted. + * exp_util.adb (Find_Storage_Op): Allow the function to return + Empty in Storage_Model_Type case rather than raising + Program_Error, so that Procedure_To_Call fields in N_Allocator + and N_Free_Statement nodes will be set to Empty in the defaulted + native storage-model case. + * sem_ch13.adb: Add with and use of System.Case_Util (and + reformat context_clause). + (Check_Aspect_At_Freeze_Point): Return with no action for a + Storage_Model_Type aspect with no expression (fully-defaulted + native memory-model case). + (Resolve_Storage_Model_Type_Argument): If an Address_Type has + not been explicitly specified, then set Addr_Type to denote type + System.Address. + (Validate_Storage_Model_Type_Aspect): Return immediately in the + case where the aspect has no Expression (fully-defaulted native + memory-model case). No longer issue an error when Address_Type + isn't specified, and instead use type System.Address as the + default address type. When the address type is + System.Address (whether specified or defaulted), no longer issue + errors for any other "subaspects" that aren't specified, since + in that case those are allowed to default as well. Remove ??? + comment about needing to check for duplicates, which is now + addressed. + (Check_And_Resolve_Storage_Model_Type_Argument): New procedure + to check that an association for a storage-model subaspect in + the aggregate has not been specified earlier in the aggregate, + and to then resolve the expression of the association and save + the resolved entity. Called by + Validate_Storage_Model_Type_Aspect. + * sem_util.ads (Storage_Model_Support): Update comments on specs + of the functions Get_Storage_Model_Type_Entity, + Storage_Model_Address_Type, and Storage_Model_Null_Address to + indicate the behavior when the address type is System.Address + (the native memory-model case). + * sem_util.adb + (Storage_Model_Support.Get_Storage_Model_Type_Entity): Suppress + the search for the given subaspect name (Nam) when the + Storage_Model_Type aspect is fully defaulted (i.e., no + Expression is present) and simply return. In cases where the + search is done, but no association that matches Nam is found, + return System.Address for the Name_Address_Type case, return + System.Null_Address for the Name_Null_Address case, and return + Empty for all other cases. + +2022-07-13 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Relocate_Expression): New routine with code that + previously was only applied to Pre and Post aspects. + (Analyze_Aspect_Specifications): Apply the above routine to + other aspects, in particular to aspects Address, Attach_Handler, + Predicate and Interrupt_Priority. + +2022-07-13 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Build_Body_To_Inline): Instead of manipulating the + Full_Analysis flag, use the Inside_A_Generic flag (which is + conveniently manipulated by Start_Generic/End_Generic, together + with Expander_Active). + * sem_attr.adb (Analyze_Attribute_Old_Result): Adapt comment and + assertion to different flag that is set while building + body-to-inline. + +2022-07-13 Alexandre Oliva <oliva@adacore.com> + + * doc/gnat_rm/security_hardening_features.rst: Clarify the need + for choices after -fzero-call-used-regs and -fstrub. + * gnat_rm.texi: Regenerate. + +2022-07-13 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Recognize a generated subtype + with Ghost pragma for generic instantiations. + +2022-07-13 Yannick Moy <moy@adacore.com> + + * libgnat/s-aridou.adb (Lemma_Mult_Div, Lemma_Powers): New + lemmas. + (Prove_Sign_Quotient): New local lemma. + (Prove_Signs): Expand definition of Big_R and Big_Q in the + postcondition. Add intermediate assertions. + (Double_Divide): Call new lemma. + (Lemma_Div_Eq): Provide body for proving lemma. + (Lemma_Powers_Of_2, Lemma_Shift_Without_Drop, + Prove_Dividend_Scaling, Prove_Multiplication, Prove_Z_Low): Call + lemmas, add intermediate assertions. + +2022-07-13 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Has_Single_Return): Add guard for the subsequent + call to Expression. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Acts_As_Spec + earlier if the body is not the completion of a declaration. + (Check_Untagged_Equality): Deal with subprogram bodies that are + not the completion of a declaration and make sure that they are + not flagged when they cause the freezing of the type themselves. + Give a warning on the freezing point of the type in more cases. + * sem_res.adb (Resolve_Equality_Op): Revert latest change. + +2022-07-13 Yannick Moy <moy@adacore.com> + + * libgnat/s-arit32.adb (Scaled_Divide32): Add an assertion, move + the call of Prove_Sign_R around. + +2022-07-13 Marc Poulhiès <poulhies@adacore.com> + + * exp_ch4.adb (Expand_N_If_Expression): Test for compile time + known bounds when handling slices. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (Integer_Type_For): Mention Small_Integer_Type_For. + (Small_Integer_Type_For): Mention Integer_Type_For. + +2022-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Resolve_Equality_Op): Make sure that the user-defined + operator of an untagged record type is declared ahead of an instance + before using it to resolve the equality operator in the instance. + +2022-07-13 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Add default + initialization for Stmts. + * sem_ch12.adb (Analyze_Associations): Add default + initialization for Match. + * libgnat/a-ztenau.adb (Scan_Enum_Lit): Remove duplicated + boolean test. + * libgnat/g-spipat.adb (XMatch): Combine duplicated cases. + +2022-07-13 Piotr Trojanek <trojanek@adacore.com> + + * par-prag.adb (Check_Arg_Count): Change parameter type from Int + to Nat, because this parameter is compared to Arg_Count variable + which is of type Nat. Also, it wouldn't make sense to check for + negative number of pragma arguments. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch11.adb (Expand_N_Exception_Declaration): Sync comment + with declaration in System.Standard_Library. + +2022-07-12 Marc Poulhiès <poulhies@adacore.com> + + * libgnat/s-secsta.adb (Has_Enough_Free_Memory): Check for full + chunk before computing the available size. + +2022-07-12 Steve Baird <baird@adacore.com> + + * exp_ch4.adb (Expand_Nonbinary_Modular_Op.Expand_Modular_Op): + Reimplement choice of which predefined type to use for the + implementation of a predefined operation of a modular type with + a non-power-of-two modulus. + +2022-07-12 Justin Squirek <squirek@adacore.com> + + * einfo.ads: Modify documentation for In_Use flag to include + scope stack manipulation. + * sem_ch8.adb (Use_One_Type): Add condition to return when + attempting to detect redundant use_type_clauses in child units + in certain cases. + +2022-07-12 Eric Botcazou <ebotcazou@adacore.com> + + * restrict.ads (type ND_Entry): Add System_Child component. + (Check_Restriction_No_Dependence_On_System): Declare. + * restrict.adb (Global_Restriction_No_Tasking): Move around. + (Violation_Of_No_Dependence): New procedure. + (Check_Restriction_No_Dependence): Call Violation_Of_No_Dependence + to report a violation. + (Check_Restriction_No_Dependence_On_System): New procedure. + (Set_Restriction_No_Dependenc): Set System_Child component if the + unit is a child of System. + * snames.ads-tmpl (Name_Arith_64): New package name. + (Name_Arith_128): Likewise. + (Name_Memory): Likewise. + (Name_Stack_Checking): Likewise. + * fe.h (Check_Restriction_No_Dependence_On_System): Declare. + +2022-07-12 Bob Duff <duff@adacore.com> + + * par.adb (P_Declarative_Items): New function to parse a + sequence of declarative items. + (P_Sequence_Of_Statements): Add Handled flag, to indicate + whether to wrap the result in a block statement. + * par-ch3.adb (P_Declarative_Item): Rename P_Declarative_Items + to be P_Declarative_Item, because it really only parses a single + declarative item, and to avoid conflict with the new + P_Declarative_Items. Add In_Statements. We keep the old + error-recovery mechanisms in place when In_Statements is False. + When True, we don't want to complain about statements, because + we are parsing a sequence of statements. + (P_Identifier_Declarations): If In_Statements, and we see what + looks like a statement, we no longer give an error. We return to + P_Sequence_Of_Statements with Done = True, so it can parse the + statement. + * par-ch5.adb (P_Sequence_Of_Statements): Call + P_Declarative_Items to parse declarative items that appear in + the statement list. Remove error handling code that complained + about such items. Check some errors conservatively. Wrap the + result in a block statement when necessary. + * par-ch11.adb (P_Handled_Sequence_Of_Statements): Pass + Handled => True to P_Sequence_Of_Statements. + * types.ads (No, Present): New functions for querying + Source_Ptrs (equal, not equal No_Location). + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Fix range of iteration. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Do not process expression of unknown restrictions. + +2022-07-12 Vasiliy Fofanov <fofanov@adacore.com> + + * makeusg.adb, + doc/gnat_ugn/building_executable_programs_with_gnat.rst: Move -P + to the top of switches list and make it clear that gnatmake + passes the ball to gprbuild if -P is set. + * gnat_ugn.texi: Regenerate. + +2022-07-12 Bob Duff <duff@adacore.com> + + * libgnat/g-socthi__vxworks.adb (C_Connect): Suppress new warning. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Set_Boolean_Result): Simplify using + Boolean_Literals. + +2022-07-12 Yannick Moy <moy@adacore.com> + + * errout.adb (Record_Compilation_Errors): Remove global + variable. + (Compilation_Errors): Simplify. + (Initialize): Inline Reset_Warnings. + (Reset_Warnings): Remove. + * errout.ads (Reset_Warnings): Remove. + (Compilation_Errors): Update comment. + * gnat1drv.adb (Adjust_Global_Switches): Ignore all frontend + warnings in GNATprove mode, except regarding elaboration and + suspicious contracts. + +2022-07-12 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Caller_Known_Size_Record): Make entry assertion + more robust and add guard for null argument. For protected + types, invoke Caller_Known_Size_Record on + Corresponding_Record_Type. + (Needs_Secondary_Stack): Likewise. + +2022-07-12 Doug Rupp <rupp@adacore.com> + + * libgnat/system-vxworks7-ppc-rtp.ads: Remove + * libgnat/system-vxworks7-x86-rtp.ads: Likewise. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation): Remove dubious + call to Set_Comes_From_Source. + +2022-07-12 Bob Duff <duff@adacore.com> + + * sem_ch5.adb (Check_Unreachable_Code): Refine heuristics. + * sem_util.ads, sem_util.adb (Is_Static_Constant_Name): Remove + this; instead we have a new function Is_Simple_Case in + Sem_Ch5.Check_Unreachable_Code. + +2022-07-12 Bob Duff <duff@adacore.com> + + * gnatls.adb (Output_License_Information): Remove pragma + No_Return; call sites deal with Exit_Program. + * libgnat/g-socthi.adb (C_Connect): Suppress warning about + unreachable code. + * sem_ch5.adb (Check_Unreachable_Code): Special-case if + statements with static conditions. If we remove unreachable + code (including the return statement) from a function, add + "raise Program_Error", so we won't warn about missing returns. + Remove Original_Node in test for N_Raise_Statement; it's not + needed. Remove test for CodePeer_Mode; if Operating_Mode = + Generate_Code, then CodePeer_Mode can't be True. Misc cleanup. + Do not reuse Nxt variable for unrelated purpose (the usage in + the Kill_Dead_Code loop is entirely local to the loop). + * sem_ch6.adb: Add check for Is_Transfer. Misc cleanup. + * sem_prag.adb: Minor. + * sem_res.adb: Minor. + * sem_util.adb: Minor cleanup. + (Is_Trivial_Boolean): Move to nonnested place, so it can be + called from elsewhere. + (Is_Static_Constant_Boolean): New function. + * sem_util.ads (Is_Trivial_Boolean): Export. + (Is_Static_Constant_Boolean): New function. + +2022-07-12 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-stchop.ads: Use a double underscore prefix for symbols. + +2022-07-12 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Check_Expression_Function.Find_Constant): Add a + check that a type that is referenced as the prefix of an + attribute is fully declared. + (Freeze_And_Append): Do not freeze the profile when freezing an + expression function. + (Freeze_Entity): When a tagged type is frozen, also freeze any + primitive operations of the type that are expression functions. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not prevent + freezing associated with an expression function body if the + function is a dispatching op. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch7.adb (Analyze_Package_Declaration): Check references to + unset objects. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Yield): Look at the entity kind, + not at the declaration kind. + +2022-07-12 Joffrey Huguet <huguet@adacore.com> + + * libgnarl/a-reatim.ads, libgnat/a-cfdlli.ads, + libgnat/a-cfhama.ads, libgnat/a-cfhase.ads, + libgnat/a-cfinse.ads, libgnat/a-cfinve.ads, + libgnat/a-cforma.ads, libgnat/a-cforse.ads, + libgnat/a-chahan.ads, libgnat/a-cofove.ads, + libgnat/a-cofuma.ads, libgnat/a-cofuse.ads, + libgnat/a-cofuve.ads, libgnat/a-nbnbin.ads, + libgnat/a-nbnbre.ads, libgnat/a-ngelfu.ads, + libgnat/a-nlelfu.ads, libgnat/a-nllefu.ads, + libgnat/a-nselfu.ads, libgnat/a-nuelfu.ads, + libgnat/a-strbou.ads, libgnat/a-strfix.ads, + libgnat/a-strmap.ads, libgnat/a-strunb.ads, + libgnat/a-strunb__shared.ads, libgnat/a-strsea.ads, + libgnat/a-textio.ads, libgnat/a-tideio.ads, + libgnat/a-tienio.ads, libgnat/a-tifiio.ads, + libgnat/a-tiflio.ads, libgnat/a-tiinio.ads, + libgnat/a-timoio.ads, libgnat/i-c.ads, libgnat/interfac.ads, + libgnat/interfac__2020.ads, libgnat/s-atacco.ads, + libgnat/s-stoele.ads: Annotate packages and subprograms with + returning annotations. + +2022-07-12 Eric Botcazou <ebotcazou@adacore.com> + + * rtsfind.ads (RE_Id): Remove RE_Str_Concat_Bounds_N values. + (RE_Unit_Table): Remove RE_Str_Concat_Bounds_N entries. + * libgnat/s-conca2.ads (Str_Concat_2): Adjust head comment. + (Str_Concat_Bounds_2): Delete. + * libgnat/s-conca2.adb (Str_Concat_2): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_2): Delete. + * libgnat/s-conca3.ads (Str_Concat_3): Adjust head comment. + (Str_Concat_Bounds_3): Delete. + * libgnat/s-conca3.adb (Str_Concat_3): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_3): Delete. + * libgnat/s-conca4.ads (Str_Concat_4): Adjust head comment. + (Str_Concat_Bounds_4): Delete. + * libgnat/s-conca4.adb (Str_Concat_4): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_4): Delete. + * libgnat/s-conca5.ads (Str_Concat_5): Adjust head comment. + (Str_Concat_Bounds_5): Delete. + * libgnat/s-conca5.adb (Str_Concat_5): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_5): Delete. + * libgnat/s-conca6.ads (Str_Concat_6): Adjust head comment. + (Str_Concat_Bounds_6): Delete. + * libgnat/s-conca6.adb (Str_Concat_6): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_6): Delete. + * libgnat/s-conca7.ads (Str_Concat_7): Adjust head comment. + (Str_Concat_Bounds_7): Delete. + * libgnat/s-conca7.adb (Str_Concat_7): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_7): Delete. + * libgnat/s-conca8.ads (Str_Concat_8): Adjust head comment. + (Str_Concat_Bounds_8): Delete. + * libgnat/s-conca8.adb (Str_Concat_8): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_8): Delete. + * libgnat/s-conca9.ads (Str_Concat_9): Adjust head comment. + (Str_Concat_Bounds_9): Delete. + * libgnat/s-conca9.adb (Str_Concat_9): Use the length of the last + input to size the last assignment. + (Str_Concat_Bounds_9): Delete. + +2022-07-12 Bob Duff <duff@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Use _Next and + _Previous in the optimized expansion of "for ... of". No longer + need to check parameter profiles for these, because the + leading-underscore names are unique. + * libgnat/a-convec.ads (_Next, _Previous): Renamings of Next and + Previous, to avoid namespace pollution. + * libgnat/a-cbdlli.ads, libgnat/a-cbhama.ads, + libgnat/a-cbhase.ads, libgnat/a-cbmutr.ads, + libgnat/a-cborma.ads, libgnat/a-cborse.ads, + libgnat/a-cdlili.ads, libgnat/a-cidlli.ads, + libgnat/a-cihama.ads, libgnat/a-cihase.ads, + libgnat/a-cimutr.ads, libgnat/a-ciorma.ads, + libgnat/a-ciorse.ads, libgnat/a-cobove.ads, + libgnat/a-cohama.ads, libgnat/a-cohase.ads, + libgnat/a-coinve.ads, libgnat/a-comutr.ads, + libgnat/a-coorma.ads, libgnat/a-coorse.ads: Likewise. Also, + remove duplicated comments -- refer to one comment about _Next, + _Previous, Pseudo_Reference in libgnat/a-convec.ads. DRY. + * scng.adb (Scan): Allow leading underscores in identifiers in + the run-time library. + * snames.ads-tmpl (Name_uNext, Name_uPrevious): New names with + leading underscores. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch5.adb (Check_Unreachable_Code): Extend suppression to + calls with No_Return aspect, but narrow it to functions. + * sem_res.adb (Resolve_Call): Warn about unreachable code after + calls with No_Return. + +2022-07-12 Bob Duff <duff@adacore.com> + + * scans.ads: Fix obsolete comments about Tok_Special, and give + Special_Character a predicate assuring it is one of the two + characters used in preprocessing. + * scng.ads: Clean up comments. + * scng.adb: Clean up handling of Tok_Special. Remove comment + about '@' (target_name), which doesn't seem very helpful. + Set_Special_Character will now blow up if given anything other + than '#' and '$', because of the predicate on Special_Character; + it's not clear why it used to say "when others => null;". + Remove Comment_Is_Token, which is not used. + * scn.ads: Remove commented-out use clause. Remove redundant + comment. + * ali-util.adb: Use "is null" for do-nothing procedures. + * gprep.adb (Post_Scan): Use "is null". + +2022-07-12 Bob Duff <duff@adacore.com> + + * libgnarl/s-solita.adb (Task_Termination_Handler_T): Ignore all + exceptions propagated by Specific_Handler. + * libgnarl/s-tassta.adb, libgnarl/s-taskin.ads: Minor. + +2022-07-12 Marc Poulhiès <poulhies@adacore.com> + + * sem.adb (Preanalyze): Suppress checks when not in GNATprove + mode. + * sem_res.adb (Preanalyze_And_Resolve): Add cross reference in + comment to above procedure. + * sinfo.ads: Typo fix in comment. + +2022-07-12 Julien Bortolussi <bortolussi@adacore.com> + + * libgnat/a-cfidll.adb, libgnat/a-cfidll.ads: Implementation + files of the formal unbounded indefinite list. + * Makefile.rtl, impunit.adb: Take into account the add of the + new files. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Variable): Remove excessive guard. + 2022-07-06 Piotr Trojanek <trojanek@adacore.com> * gcc-interface/Make-lang.in (ada/generated/gnatvsn.ads): diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 3ae4e23..00137f2 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -113,6 +113,7 @@ GNATRTL_NONTASKING_OBJS= \ a-cfdlli$(objext) \ a-cfhama$(objext) \ a-cfhase$(objext) \ + a-cfidll$(objext) \ a-cfinve$(objext) \ a-cfinse$(objext) \ a-cforma$(objext) \ diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index bb1fc41..6435905 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -42,15 +42,12 @@ package body ALI.Util is -- empty, because we don't want to report any errors when computing -- a source checksum. - procedure Post_Scan; + procedure Post_Scan is null; - procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); - - procedure Error_Msg_S (Msg : String); - - procedure Error_Msg_SC (Msg : String); - - procedure Error_Msg_SP (Msg : String); + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is null; + procedure Error_Msg_S (Msg : String) is null; + procedure Error_Msg_SC (Msg : String) is null; + procedure Error_Msg_SP (Msg : String) is null; -- Instantiation of Styleg, needed to instantiate Scng @@ -85,47 +82,6 @@ package body ALI.Util is return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error; end Checksums_Match; - --------------- - -- Error_Msg -- - --------------- - - procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is - pragma Warnings (Off, Msg); - pragma Warnings (Off, Flag_Location); - begin - null; - end Error_Msg; - - ----------------- - -- Error_Msg_S -- - ----------------- - - procedure Error_Msg_S (Msg : String) is - pragma Warnings (Off, Msg); - begin - null; - end Error_Msg_S; - - ------------------ - -- Error_Msg_SC -- - ------------------ - - procedure Error_Msg_SC (Msg : String) is - pragma Warnings (Off, Msg); - begin - null; - end Error_Msg_SC; - - ------------------ - -- Error_Msg_SP -- - ------------------ - - procedure Error_Msg_SP (Msg : String) is - pragma Warnings (Off, Msg); - begin - null; - end Error_Msg_SP; - ----------------------- -- Get_File_Checksum -- ----------------------- @@ -192,15 +148,6 @@ package body ALI.Util is Interfaces.Reset; end Initialize_ALI_Source; - --------------- - -- Post_Scan -- - --------------- - - procedure Post_Scan is - begin - null; - end Post_Scan; - ---------------------- -- Read_Withed_ALIs -- ---------------------- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 658a859..6559cda 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -441,7 +441,7 @@ package Aspects is Aspect_SPARK_Mode => Optional_Name, Aspect_Stable_Properties => Expression, Aspect_Static_Predicate => Expression, - Aspect_Storage_Model_Type => Expression, + Aspect_Storage_Model_Type => Optional_Expression, Aspect_Storage_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst index f4f752d..f5fdc8e 100644 --- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst +++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst @@ -18,9 +18,10 @@ Register Scrubbing GNAT can generate code to zero-out hardware registers before returning from a subprogram. -It can be enabled with the :switch:`-fzero-call-used-regs` command-line -option, to affect all subprograms in a compilation, and with a -:samp:`Machine_Attribute` pragma, to affect only specific subprograms. +It can be enabled with the :switch:`-fzero-call-used-regs={choice}` +command-line option, to affect all subprograms in a compilation, and +with a :samp:`Machine_Attribute` pragma, to affect only specific +subprograms. .. code-block:: ada @@ -73,11 +74,11 @@ or a variable.) -- scrubbing of the stack space used by that subprogram. -There are also :switch:`-fstrub` command-line options to control -default settings. For usage and more details on the command-line -option, on the ``strub`` attribute, and their use with other -programming languages, see :title:`Using the GNU Compiler Collection -(GCC)`. +There are also :switch:`-fstrub={choice}` command-line options to +control default settings. For usage and more details on the +command-line options, on the ``strub`` attribute, and their use with +other programming languages, see :title:`Using the GNU Compiler +Collection (GCC)`. Note that Ada secondary stacks are not scrubbed. The restriction ``No_Secondary_Stack`` avoids their use, and thus their accidental 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 c0eeca4..5442d55 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 @@ -139,6 +139,17 @@ You may specify any of the following switches to ``gnatmake``: all other options. +.. index:: -P (gnatmake) + +:switch:`-P{project}` + Build GNAT project file ``project`` using GPRbuild. When this switch is + present, all other command-line switches are treated as GPRbuild switches + and not ``gnatmake`` switches. + +.. -- Comment: + :ref:`gnatmake_and_Project_Files`. + + .. index:: --GCC=compiler_name (gnatmake) :switch:`--GCC={compiler_name}` @@ -522,15 +533,6 @@ You may specify any of the following switches to ``gnatmake``: :switch:`-p` Same as :switch:`--create-missing-dirs` -.. index:: -P (gnatmake) - -:switch:`-P{project}` - Use project file ``project``. Only one such switch can be used. - -.. -- Comment: - :ref:`gnatmake_and_Project_Files`. - - .. index:: -q (gnatmake) :switch:`-q` diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c5843f2..ed63019 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2309,6 +2309,10 @@ package Einfo is -- the corresponding entity. Reset at end of corresponding declarative -- part. The flag on a type is also used to determine the visibility of -- the primitive operators of the type. +-- +-- Note that manipulation of scopes on the scope stack will also cause +-- the flag to be set/unset since the setting of scopes affects +-- visibility. -- Is_Abstract_Subprogram -- Defined in all subprograms and entries. Set for abstract subprograms. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 4e095a7..79e162a 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -64,13 +64,6 @@ package body Errout is Finalize_Called : Boolean := False; -- Set True if the Finalize routine has been called - Record_Compilation_Errors : Boolean := False; - -- Record that a compilation error was witnessed during a given phase of - -- analysis for gnat2why. This is needed as Warning_Mode is modified twice - -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable - -- value for each phase of analysis separately. This is updated at each - -- call to Compilation_Errors. - Warn_On_Instance : Boolean; -- Flag set true for warning message to be posted on instance @@ -252,17 +245,8 @@ package body Errout is begin if not Finalize_Called then raise Program_Error; - - -- Record that a compilation error was witnessed during a given phase of - -- analysis for gnat2why. This is needed as Warning_Mode is modified - -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a - -- suitable value for each phase of analysis separately. - else - Record_Compilation_Errors := - Record_Compilation_Errors or else Erroutc.Compilation_Errors; - - return Record_Compilation_Errors; + return Erroutc.Compilation_Errors; end if; end Compilation_Errors; @@ -1914,7 +1898,10 @@ package body Errout is -- Reset counts for warnings - Reset_Warnings; + Warnings_Treated_As_Errors := 0; + Warnings_Detected := 0; + Warning_Info_Messages := 0; + Warnings_As_Errors_Count := 0; -- Initialize warnings tables @@ -3414,18 +3401,6 @@ package body Errout is end loop; end Remove_Warning_Messages; - -------------------- - -- Reset_Warnings -- - -------------------- - - procedure Reset_Warnings is - begin - Warnings_Treated_As_Errors := 0; - Warnings_Detected := 0; - Warning_Info_Messages := 0; - Warnings_As_Errors_Count := 0; - end Reset_Warnings; - ---------------------- -- Adjust_Name_Case -- ---------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index c115a1b..45166f5 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -858,11 +858,6 @@ package Errout is -- Remove warnings on all elements of a list (Calls Remove_Warning_Messages -- on each element of the list, see above). - procedure Reset_Warnings; - -- Reset the counts related to warnings. This is used both to initialize - -- these counts and to reset them after each phase of analysis for a given - -- value of Opt.Warning_Mode in gnat2why. - procedure Set_Ignore_Errors (To : Boolean); -- Following a call to this procedure with To=True, all error calls are -- ignored. A call with To=False restores the default treatment in which @@ -910,11 +905,10 @@ package Errout is -- matching Warnings Off pragma preceding this one. function Compilation_Errors return Boolean; - -- Returns True if errors have been detected, or warnings in -gnatwe (treat - -- warnings as errors) mode. Note that it is mandatory to call Finalize - -- before calling this routine. To account for changes to Warning_Mode in - -- gnat2why between phases, the past or current presence of an error is - -- recorded in a global variable at each call. + -- Returns True if errors have been detected, or warnings when they are + -- treated as errors, which corresponds to switch -gnatwe in the compiler, + -- and other switches in other tools. Note that it is mandatory to call + -- Finalize before calling this routine. procedure Error_Msg_CRT (Feature : String; N : Node_Id); -- Posts a non-fatal message on node N saying that the feature identified diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index c60fe34..c4a59f5 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1136,7 +1136,7 @@ package body Exp_Ch11 is Set_Is_Statically_Allocated (Ex_Id); -- Create the aggregate list for type Standard.Exception_Type: - -- Handled_By_Other component: False + -- Not_Handled_By_Others component: False L := Empty_List; Append_To (L, New_Occurrence_Of (Standard_False, Loc)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 288ce9a9..18fb88f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4177,43 +4177,82 @@ package body Exp_Ch4 is ----------------------- procedure Expand_Modular_Op is + -- We will convert to another type (not a nonbinary-modulus modular + -- type), evaluate the op in that representation, reduce the result, + -- and convert back to the original type. This means that the + -- backend does not have to deal with nonbinary-modulus ops. + Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); - Target_Type : Entity_Id; - + Target_Type : Entity_Id; begin - -- Convert nonbinary modular type operands into integer values. Thus - -- we avoid never-ending loops expanding them, and we also ensure - -- the back end never receives nonbinary modular type expressions. - - if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then - Set_Left_Opnd (Op_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Op_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Right_Opnd (N)))); - Set_Left_Opnd (Mod_Expr, - Unchecked_Convert_To (Standard_Integer, Op_Expr)); + -- Select a target type that is large enough to avoid spurious + -- intermediate overflow on pre-reduction computation (for + -- correctness) but is no larger than is needed (for performance). - else - -- If the modulus of the type is larger than Integer'Last use a - -- larger type for the operands, to prevent spurious constraint - -- errors on large legal literals of the type. - - if Modulus (Etype (N)) > Int (Integer'Last) then - Target_Type := Standard_Long_Long_Integer; + declare + Required_Size : Uint := RM_Size (Etype (N)); + Use_Unsigned : Boolean := True; + begin + case Nkind (N) is + when N_Op_Add => + -- For example, if modulus is 255 then RM_Size will be 8 + -- and the range of possible values (before reduction) will + -- be 0 .. 508; that range requires 9 bits. + Required_Size := Required_Size + 1; + + when N_Op_Subtract => + -- For example, if modulus is 255 then RM_Size will be 8 + -- and the range of possible values (before reduction) will + -- be -254 .. 254; that range requires 9 bits, signed. + Use_Unsigned := False; + Required_Size := Required_Size + 1; + + when N_Op_Multiply => + -- For example, if modulus is 255 then RM_Size will be 8 + -- and the range of possible values (before reduction) will + -- be 0 .. 64,516; that range requires 16 bits. + Required_Size := Required_Size * 2; + + when others => + null; + end case; + + if Use_Unsigned then + if Required_Size <= Standard_Short_Short_Integer_Size then + Target_Type := Standard_Short_Short_Unsigned; + elsif Required_Size <= Standard_Short_Integer_Size then + Target_Type := Standard_Short_Unsigned; + elsif Required_Size <= Standard_Integer_Size then + Target_Type := Standard_Unsigned; + else + pragma Assert (Required_Size <= 64); + Target_Type := Standard_Unsigned_64; + end if; + elsif Required_Size <= 8 then + Target_Type := Standard_Integer_8; + elsif Required_Size <= 16 then + Target_Type := Standard_Integer_16; + elsif Required_Size <= 32 then + Target_Type := Standard_Integer_32; else - Target_Type := Standard_Integer; + pragma Assert (Required_Size <= 64); + Target_Type := Standard_Integer_64; end if; - Set_Left_Opnd (Op_Expr, - Unchecked_Convert_To (Target_Type, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Op_Expr, - Unchecked_Convert_To (Target_Type, - New_Copy_Tree (Right_Opnd (N)))); + pragma Assert (Present (Target_Type)); + end; + + Set_Left_Opnd (Op_Expr, + Unchecked_Convert_To (Target_Type, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Op_Expr, + Unchecked_Convert_To (Target_Type, + New_Copy_Tree (Right_Opnd (N)))); + + -- ??? Why do this stuff for some ops and not others? + if Nkind (N) not in N_Op_And | N_Op_Or | N_Op_Xor then -- Link this node to the tree to analyze it @@ -4237,10 +4276,10 @@ package body Exp_Ch4 is -- several times. Force_Evaluation (Op_Expr, Mode => Strict); - - Set_Left_Opnd (Mod_Expr, Op_Expr); end if; + Set_Left_Opnd (Mod_Expr, Op_Expr); + Set_Right_Opnd (Mod_Expr, Make_Integer_Literal (Loc, Modulus (Typ))); @@ -6135,7 +6174,13 @@ package body Exp_Ch4 is Slice_Bnd : Node_Id) return Node_Id is begin - if Nkind (Elsex) = N_Slice then + -- We need to use the special processing for slices only if + -- they do not have compile-time known bounds; if they do, they + -- can be treated like any other expressions. + + if Nkind (Elsex) = N_Slice + and then not Compile_Time_Known_Bounds (Etype (Elsex)) + then if Compile_Time_Known_Value (Slice_Bnd) and then Expr_Value (Slice_Bnd) = Then_Bnd then @@ -6191,7 +6236,11 @@ package body Exp_Ch4 is begin Get_First_Index_Bounds (Etype (Thenx), Then_Lo, Then_Hi); - if Nkind (Elsex) = N_Slice then + -- See the rationale in Build_New_Bound + + if Nkind (Elsex) = N_Slice + and then not Compile_Time_Known_Bounds (Etype (Elsex)) + then Slice_Lo := Low_Bound (Discrete_Range (Elsex)); Slice_Hi := High_Bound (Discrete_Range (Elsex)); Get_First_Index_Bounds @@ -6250,7 +6299,11 @@ package body Exp_Ch4 is Set_Suppress_Assignment_Checks (Last (Then_List)); - if Nkind (Elsex) = N_Slice then + -- See the rationale in Build_New_Bound + + if Nkind (Elsex) = N_Slice + and then not Compile_Time_Known_Bounds (Etype (Elsex)) + then Else_List := New_List ( Make_Assignment_Statement (Loc, Name => diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2072935..9a2a110 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4924,7 +4924,8 @@ package body Exp_Ch5 is -- In the optimized case, we make use of these: - -- procedure Next (Position : in out Cursor); -- instead of Iter.Next + -- procedure _Next (Position : in out Cursor); -- instead of Iter.Next + -- (or _Previous for reverse loops) -- function Pseudo_Reference -- (Container : aliased Vector'Class) return Reference_Control_Type; @@ -4939,6 +4940,11 @@ package body Exp_Ch5 is -- pollute the namespace for clients. The compiler has no trouble breaking -- privacy to call things in the private part of an instance.) + -- Note that Next and Previous are renamed as _Next and _Previous with + -- leading underscores. Leading underscores are illegal in Ada, but we + -- allow them in the run-time library. This allows us to avoid polluting + -- the user-visible namespaces. + -- Source: -- for X of My_Vector loop @@ -4989,7 +4995,7 @@ package body Exp_Ch5 is -- X.Count := X.Count + 1; -- ... -- - -- Next (Cur); -- or Prev + -- _Next (Cur); -- or _Previous -- -- This is instead of "Cur := Next (Iter, Cur);" -- end; -- -- No finalization here @@ -5015,13 +5021,14 @@ package body Exp_Ch5 is Stats : List_Id := Statements (N); -- Maybe wrapped in a conditional if a filter is present - Cursor : Entity_Id; - Decl : Node_Id; - Iter_Type : Entity_Id; - Iterator : Entity_Id; - Name_Init : Name_Id; - Name_Step : Name_Id; - New_Loop : Node_Id; + Cursor : Entity_Id; + Decl : Node_Id; + Iter_Type : Entity_Id; + Iterator : Entity_Id; + Name_Init : Name_Id; + Name_Step : Name_Id; + Name_Fast_Step : Name_Id; + New_Loop : Node_Id; Fast_Element_Access_Op : Entity_Id := Empty; Fast_Step_Op : Entity_Id := Empty; @@ -5049,9 +5056,11 @@ package body Exp_Ch5 is if Reverse_Present (I_Spec) then Name_Init := Name_Last; Name_Step := Name_Previous; + Name_Fast_Step := Name_uPrevious; else Name_Init := Name_First; Name_Step := Name_Next; + Name_Fast_Step := Name_uNext; end if; -- The type of the iterator is the return type of the Iterate function @@ -5189,14 +5198,13 @@ package body Exp_Ch5 is Iter_Pack := Scope (Root_Type (Etype (Iter_Type))); - -- Find declarations needed for "for ... of" optimization + -- Find declarations needed for "for ... of" optimization. -- These declarations come from GNAT sources or sources -- derived from them. User code may include additional -- overloadings with similar names, and we need to perforn -- some reasonable resolution to find the needed primitives. - -- It is unclear whether this mechanism is fragile if a user - -- makes arbitrary changes to the private part of a package - -- that supports iterators. + -- Note that we use _Next or _Previous to avoid picking up + -- some arbitrary user-defined Next or Previous. Ent := First_Entity (Pack); while Present (Ent) loop @@ -5215,12 +5223,7 @@ package body Exp_Ch5 is -- Next or Prev procedure with one parameter called -- Position. - elsif Chars (Ent) = Name_Step - and then Ekind (Ent) = E_Procedure - and then Present (First_Formal (Ent)) - and then Chars (First_Formal (Ent)) = Name_Position - and then No (Next_Formal (First_Formal (Ent))) - then + elsif Chars (Ent) = Name_Fast_Step then pragma Assert (No (Fast_Step_Op)); Fast_Step_Op := Ent; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index bf51e64..fad130d 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5175,7 +5175,7 @@ package body Exp_Ch6 is Exp : Node_Id; HSS : Node_Id; Result : Node_Id; - Stmts : List_Id; + Stmts : List_Id := No_List; Return_Stmt : Node_Id := Empty; -- Force initialization to facilitate static analysis diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8557e4b..3286bf6 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6406,16 +6406,7 @@ package body Exp_Util is begin if Has_Storage_Model_Type_Aspect (Typ) then - declare - SMT_Op : constant Entity_Id := - Get_Storage_Model_Type_Entity (Typ, Nam); - begin - if not Present (SMT_Op) then - raise Program_Error; - else - return SMT_Op; - end if; - end; + return Get_Storage_Model_Type_Entity (Typ, Nam); -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e812ca0..d854672 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -623,8 +623,10 @@ package Exp_Util is -- specifies aspect Storage_Model_Type, returns the Entity_Id of the -- subprogram associated with Nam, which must either be a primitive op of -- the type in the case of a storage pool, or the operation corresponding - -- to Nam as specified in the aspect Storage_Model_Type. It is an error if - -- no operation corresponding to the given name is found. + -- to Nam as specified in the aspect Storage_Model_Type. In the case of + -- aspect Storage_Model_Type, returns Empty when no operation is found, + -- indicating that the operation is defaulted in the aspect (can occur in + -- the case where the storage-model address type is System.Address). function Find_Hook_Context (N : Node_Id) return Node_Id; -- Determine a suitable node on which to attach actions related to N that @@ -758,7 +760,7 @@ package Exp_Util is function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id; -- Return a suitable standard integer type containing at least S bits and - -- of the signedness given by Uns. + -- of the signedness given by Uns. See also Small_Integer_Type_For. function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean; @@ -1193,7 +1195,7 @@ package Exp_Util is function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id; -- Return the smallest standard integer type containing at least S bits and - -- of the signedness given by Uns. + -- of the signedness given by Uns. See also Integer_Type_For. function Thunk_Target (Thunk : Entity_Id) return Entity_Id; -- Return the entity ultimately called by the thunk, that is to say return diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 983f6c3..b002bdc 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -252,6 +252,8 @@ extern Boolean SJLJ_Exceptions (void); restrict__check_no_implicit_protected_alloc #define Check_No_Implicit_Task_Alloc \ restrict__check_no_implicit_task_alloc +#define Check_Restriction_No_Dependence_On_System \ + restrict__check_restriction_no_dependence_on_system #define No_Exception_Handlers_Set \ restrict__no_exception_handlers_set #define No_Exception_Propagation_Active \ @@ -262,6 +264,7 @@ extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); 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 void Check_Restriction_No_Dependence_On_System (Name_Id, Node_Id); extern Boolean No_Exception_Handlers_Set (void); extern Boolean No_Exception_Propagation_Active (void); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 3a33373..382e5b4 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1470,6 +1470,10 @@ package body Freeze is if Is_Entity_Name (Prefix (Nod)) and then Is_Type (Entity (Prefix (Nod))) then + if Expander_Active then + Check_Fully_Declared (Entity (Prefix (Nod)), N); + end if; + Freeze_Before (N, Entity (Prefix (Nod))); end if; end if; @@ -2632,7 +2636,13 @@ package body Freeze is N : Node_Id; Result : in out List_Id) is - L : constant List_Id := Freeze_Entity (Ent, N); + -- Freezing an Expression_Function does not freeze its profile: + -- the formals will have been frozen otherwise before the E_F + -- can be called. + + L : constant List_Id := + Freeze_Entity + (Ent, N, Do_Freeze_Profile => not Is_Expression_Function (Ent)); begin if Is_Non_Empty_List (L) then if Result = No_List then @@ -7807,11 +7817,37 @@ package body Freeze is -- type itself is frozen, because the class-wide type refers to the -- tagged type which generates the class. + -- For a tagged type, freeze explicitly those primitive operations + -- that are expression functions, which otherwise have no clear + -- freeze point: these have to be frozen before the dispatch table + -- for the type is built, and before any explicit call to the + -- primitive, which would otherwise be the freeze point for it. + if Is_Tagged_Type (E) and then not Is_Class_Wide_Type (E) and then Present (Class_Wide_Type (E)) then Freeze_And_Append (Class_Wide_Type (E), N, Result); + + declare + Ops : constant Elist_Id := Primitive_Operations (E); + + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + if Ops /= No_Elist then + Elmt := First_Elmt (Ops); + while Present (Elmt) loop + Subp := Node (Elmt); + if Is_Expression_Function (Subp) then + Freeze_And_Append (Subp, N, Result); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end; end if; end if; diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 99277f0..96ea13e 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -212,6 +212,7 @@ static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *); static int adjust_packed (tree, tree, int); static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool); static enum inline_status_t inline_status_for_subprog (Entity_Id); +static Entity_Id Gigi_Cloned_Subtype (Entity_Id); static tree gnu_ext_name_for_subprog (Entity_Id, tree); static void set_nonaliased_component_on_array_type (tree); static void set_reverse_storage_order_on_array_type (tree); @@ -301,8 +302,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) const bool foreign = Has_Foreign_Convention (gnat_entity); /* For a type, contains the equivalent GNAT node to be used in gigi. */ Entity_Id gnat_equiv_type = Empty; - /* For a type, contains the GNAT node to be used for back-annotation. */ - Entity_Id gnat_annotate_type = Empty; + /* For a subtype, contains the GNAT node to be used as cloned subtype. */ + Entity_Id gnat_cloned_subtype = Empty; /* Temporary used to walk the GNAT tree. */ Entity_Id gnat_temp; /* Contains the GCC DECL node which is equivalent to the input GNAT node. @@ -1807,6 +1808,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) case E_Modular_Integer_Subtype: case E_Ordinary_Fixed_Point_Subtype: case E_Decimal_Fixed_Point_Subtype: + gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity); + if (Present (gnat_cloned_subtype)) + break; /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do not want to call create_range_type since we would like each subtype @@ -2035,6 +2039,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) break; case E_Floating_Point_Subtype: + gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity); + if (Present (gnat_cloned_subtype)) + break; + /* See the E_Signed_Integer_Subtype case for the rationale. */ if (!definition && Present (Ancestor_Subtype (gnat_entity)) @@ -2102,15 +2110,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) const bool convention_fortran_p = (Convention (gnat_entity) == Convention_Fortran); const int ndim = Number_Dimensions (gnat_entity); - tree gnu_template_type; - tree gnu_ptr_template; - tree gnu_template_reference, gnu_template_fields, gnu_fat_type; + tree gnu_fat_type, gnu_template_type, gnu_ptr_template; + tree gnu_template_reference, gnu_template_fields; tree *gnu_index_types = XALLOCAVEC (tree, ndim); tree *gnu_temp_fields = XALLOCAVEC (tree, ndim); - tree gnu_max_size = size_one_node, tem, obj; + tree gnu_max_size = size_one_node; + tree comp_type, tem, obj; Entity_Id gnat_index; + alias_set_type ptr_set = -1; int index; - tree comp_type; /* Create the type for the component now, as it simplifies breaking type reference loops. */ @@ -2181,6 +2189,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (COMPLETE_TYPE_P (gnu_fat_type)) { tem = TYPE_FIELDS (gnu_fat_type); + if (TYPE_ALIAS_SET_KNOWN_P (TREE_TYPE (tem))) + ptr_set = TYPE_ALIAS_SET (TREE_TYPE (tem)); TREE_TYPE (tem) = ptr_type_node; TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template; TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0; @@ -2389,7 +2399,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE); /* Adjust the type of the pointer-to-array field of the fat pointer - and record the aliasing relationships if necessary. If this is + and preserve its existing alias set, if any. Note that calling + again record_component_aliases on the fat pointer is not enough + because this may leave dangling references to the existing alias + set from types containing a fat pointer component. If this is a packed type implemented specially, then use a ref-all pointer type since the implementation type may vary between constrained subtypes and unconstrained base type. */ @@ -2398,8 +2411,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = build_pointer_type_for_mode (tem, ptr_mode, true); else TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); - if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type)) - record_component_aliases (gnu_fat_type); + if (ptr_set != -1) + TYPE_ALIAS_SET (TREE_TYPE (TYPE_FIELDS (gnu_fat_type))) = ptr_set; /* If the maximum size doesn't overflow, use it. */ if (gnu_max_size @@ -2441,6 +2454,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) break; case E_Array_Subtype: + gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity); + if (Present (gnat_cloned_subtype)) + break; /* This is the actual data type for array variables. Multidimensional arrays are implemented as arrays of arrays. Note that arrays which @@ -3438,18 +3454,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* ... fall through ... */ case E_Record_Subtype: - /* If Cloned_Subtype is Present it means this record subtype has - identical layout to that type or subtype and we should use - that GCC type for this one. The front-end guarantees that - the component list is shared. */ - if (Present (Cloned_Subtype (gnat_entity))) - { - gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), - NULL_TREE, false); - gnat_annotate_type = Cloned_Subtype (gnat_entity); - maybe_present = true; - break; - } + gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity); + if (Present (gnat_cloned_subtype)) + break; /* Otherwise, first ensure the base type is elaborated. Then, if we are changing the type, make a new type with each field having the type of @@ -3860,9 +3867,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) break; case E_Access_Subtype: + gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity); + if (Present (gnat_cloned_subtype)) + break; + /* We treat this as identical to its base type; any constraint is meaningful only to the front-end. */ - gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false); + gnu_type = gnat_to_gnu_type (gnat_equiv_type); maybe_present = true; /* The designated subtype must be elaborated as well, if it does @@ -3872,11 +3883,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && Is_Frozen (Directly_Designated_Type (gnat_entity)) && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) { - tree gnu_base_type = TREE_TYPE (gnu_decl); - tree gnu_desig_base_type - = TYPE_IS_FAT_POINTER_P (gnu_base_type) - ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_base_type))) - : TREE_TYPE (gnu_base_type); + tree gnu_design_base_type + = TYPE_IS_FAT_POINTER_P (gnu_type) + ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_type))) + : TREE_TYPE (gnu_type); /* If we are to defer elaborating incomplete types, make a dummy type node and elaborate it later. */ @@ -3893,7 +3903,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Otherwise elaborate the designated subtype only if its base type has already been elaborated. */ - else if (!TYPE_IS_DUMMY_P (gnu_desig_base_type)) + else if (!TYPE_IS_DUMMY_P (gnu_design_base_type)) gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), NULL_TREE, false); } @@ -4273,6 +4283,27 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gcc_unreachable (); } + /* If this is the clone of a subtype, just reuse the cloned subtype; another + approach would be to set the cloned subtype as the DECL_ORIGINAL_TYPE of + the entity, which would generate a DW_TAG_typedef in the debug info, but + at the cost of the duplication of the GCC type and, more annoyingly, of + the need to update the copy if the cloned subtype is not complete yet. */ + if (Present (gnat_cloned_subtype)) + { + gnu_decl = gnat_to_gnu_entity (gnat_cloned_subtype, NULL_TREE, false); + maybe_present = true; + + if (!TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) + { + if (!Known_Alignment (gnat_entity)) + Copy_Alignment (gnat_entity, gnat_cloned_subtype); + if (!Known_Esize (gnat_entity)) + Copy_Esize (gnat_entity, gnat_cloned_subtype); + if (!Known_RM_Size (gnat_entity)) + Copy_RM_Size (gnat_entity, gnat_cloned_subtype); + } + } + /* If we had a case where we evaluated another type and it might have defined this one, handle it here. */ if (maybe_present && present_gnu_tree (gnat_entity)) @@ -4754,27 +4785,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else gnu_decl = create_type_decl (gnu_entity_name, gnu_type, artificial_p, debug_info_p, gnat_entity); - - /* For vector types, make the representative array the debug type. */ - if (VECTOR_TYPE_P (gnu_type)) - { - tree rep = TYPE_REPRESENTATIVE_ARRAY (gnu_type); - TYPE_NAME (rep) = DECL_NAME (gnu_decl); - SET_TYPE_DEBUG_TYPE (gnu_type, rep); - } - } - - /* Otherwise, for a type reusing an existing DECL, back-annotate values. */ - else if (is_type - && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) - && Present (gnat_annotate_type)) - { - if (!Known_Alignment (gnat_entity)) - Copy_Alignment (gnat_entity, gnat_annotate_type); - if (!Known_Esize (gnat_entity)) - Copy_Esize (gnat_entity, gnat_annotate_type); - if (!Known_RM_Size (gnat_entity)) - Copy_RM_Size (gnat_entity, gnat_annotate_type); } /* If we haven't already, associate the ..._DECL node that we just made with @@ -5110,6 +5120,71 @@ finalize_from_limited_with (void) } } +/* Return the cloned subtype to be used for GNAT_ENTITY, if the latter is a + kind of subtype that needs to be considered as a clone by Gigi, otherwise + return Empty. */ + +static Entity_Id +Gigi_Cloned_Subtype (Entity_Id gnat_entity) +{ + Node_Id gnat_decl; + + switch (Ekind (gnat_entity)) + { + case E_Class_Wide_Subtype: + if (Present (Equivalent_Type (gnat_entity))) + return Empty; + + /* ... fall through ... */ + + case E_Record_Subtype: + /* If Cloned_Subtype is Present, this means that this record subtype has + the same layout as that of the specified (sub)type, and also that the + front-end guarantees that the component list is shared. */ + return Cloned_Subtype (gnat_entity); + + case E_Access_Subtype: + case E_Array_Subtype: + case E_Signed_Integer_Subtype: + case E_Enumeration_Subtype: + case E_Modular_Integer_Subtype: + case E_Ordinary_Fixed_Point_Subtype: + case E_Decimal_Fixed_Point_Subtype: + case E_Floating_Point_Subtype: + if (Sloc (gnat_entity) == Standard_Location) + break; + + /* We return true for the subtypes generated for the actuals of formal + private types in instantiations, so that these actuals are the types + of the instantiated objects in the debug info. */ + gnat_decl = Declaration_Node (gnat_entity); + if (Present (gnat_decl) + && Nkind (gnat_decl) == N_Subtype_Declaration + && Present (Generic_Parent_Type (gnat_decl)) + && Is_Entity_Name (Subtype_Indication (gnat_decl))) + return Entity (Subtype_Indication (gnat_decl)); + + /* Likewise for the full view of such subtypes when they are private. */ + if (Is_Itype (gnat_entity)) + { + gnat_decl = Associated_Node_For_Itype (gnat_entity); + if (Present (gnat_decl) + && Nkind (gnat_decl) == N_Subtype_Declaration + && Is_Private_Type (Defining_Identifier (gnat_decl)) + && Full_View (Defining_Identifier (gnat_decl)) == gnat_entity + && Present (Generic_Parent_Type (gnat_decl)) + && Is_Entity_Name (Subtype_Indication (gnat_decl))) + return Entity (Subtype_Indication (gnat_decl)); + } + break; + + default: + break; + } + + return Empty; +} + /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind of type (such E_Task_Type) that has a different type which Gigi uses for its representation. If the type does not have a special type for diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 8164801..c1dd567 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -364,7 +364,12 @@ gigi (Node_Id gnat_root, /* Enable GNAT stack checking method if needed */ if (!Stack_Check_Probes_On_Target) - set_stack_check_libfunc ("_gnat_stack_check"); + { + set_stack_check_libfunc ("__gnat_stack_check"); + if (flag_stack_check != NO_STACK_CHECK) + Check_Restriction_No_Dependence_On_System (Name_Stack_Checking, + gnat_root); + } /* Retrieve alignment settings. */ double_float_alignment = get_target_double_float_alignment (); @@ -6933,9 +6938,18 @@ gnat_to_gnu (Node_Id gnat_node) = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); } + /* If this is a comparison between (potentially) large aggregates, then + declare the dependence on the memcmp routine. */ + else if ((kind == N_Op_Eq || kind == N_Op_Ne) + && AGGREGATE_TYPE_P (TREE_TYPE (gnu_lhs)) + && (!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_lhs))) + || compare_tree_int (TYPE_SIZE (TREE_TYPE (gnu_lhs)), + 2 * BITS_PER_WORD) > 0)) + Check_Restriction_No_Dependence_On_System (Name_Memory_Compare, + gnat_node); + /* Pending generic support for efficient vector logical operations in - GCC, convert vectors to their representative array type view and - fallthrough. */ + GCC, convert vectors to their representative array type view. */ gnu_lhs = maybe_vector_array (gnu_lhs); gnu_rhs = maybe_vector_array (gnu_rhs); @@ -7167,7 +7181,7 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Assignment_Statement: - /* Get the LHS and RHS of the statement and convert any reference to an + /* First get the LHS of the statement and convert any reference to an unconstrained array into a reference to the underlying array. */ gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); @@ -7177,6 +7191,8 @@ gnat_to_gnu (Node_Id gnat_node) && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node, N_Raise_Storage_Error); + + /* If the RHS is a function call, let Call_to_gnu do the entire work. */ else if (Nkind (Expression (gnat_node)) == N_Function_Call) { get_atomic_access (Name (gnat_node), &aa_type, &aa_sync); @@ -7184,6 +7200,8 @@ gnat_to_gnu (Node_Id gnat_node) = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs, aa_type, aa_sync); } + + /* Otherwise we need to build the assignment statement manually. */ else { const Node_Id gnat_expr = Expression (gnat_node); @@ -7209,6 +7227,9 @@ gnat_to_gnu (Node_Id gnat_node) && Is_Single_Aggregate (gnat_temp)); gnu_rhs = gnat_to_gnu (gnat_temp); } + + /* Otherwise get the RHS of the statement and do the same processing + as for the LHS above. */ else gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr)); @@ -7254,6 +7275,8 @@ gnat_to_gnu (Node_Id gnat_node) value = int_const_binop (BIT_AND_EXPR, value, mask); } gnu_result = build_call_expr (t, 3, dest, value, size); + Check_Restriction_No_Dependence_On_System (Name_Memory_Set, + gnat_node); } /* Otherwise build a regular assignment. */ @@ -7278,7 +7301,18 @@ gnat_to_gnu (Node_Id gnat_node) tree from_ptr = build_fold_addr_expr (from); tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE); gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size); + Check_Restriction_No_Dependence_On_System (Name_Memory_Move, + gnat_node); } + + /* If this is an assignment between (potentially) large aggregates, + then declare the dependence on the memcpy routine. */ + else if (AGGREGATE_TYPE_P (TREE_TYPE (gnu_lhs)) + && (!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_lhs))) + || compare_tree_int (TYPE_SIZE (TREE_TYPE (gnu_lhs)), + 2 * BITS_PER_WORD) > 0)) + Check_Restriction_No_Dependence_On_System (Name_Memory_Copy, + gnat_node); } break; @@ -8437,27 +8471,37 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node) && !TYPE_FAT_POINTER_P (type)) MARK_VISITED (TYPE_ADA_SIZE (type)); - /* If this is a variable and an initializer is attached to it, it must be - valid for the context. Similar to init_const in create_var_decl. */ - if (TREE_CODE (gnu_decl) == VAR_DECL - && (gnu_init = DECL_INITIAL (gnu_decl)) - && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init)) + if (TREE_CODE (gnu_decl) == VAR_DECL && (gnu_init = DECL_INITIAL (gnu_decl))) + { + /* If this is a variable and an initializer is attached to it, it must be + valid for the context. Similar to init_const in create_var_decl. */ + if (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init)) || (TREE_STATIC (gnu_decl) && !initializer_constant_valid_p (gnu_init, - TREE_TYPE (gnu_init))))) - { - DECL_INITIAL (gnu_decl) = NULL_TREE; - if (TREE_READONLY (gnu_decl)) + TREE_TYPE (gnu_init)))) { - TREE_READONLY (gnu_decl) = 0; - DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; - } + DECL_INITIAL (gnu_decl) = NULL_TREE; + if (TREE_READONLY (gnu_decl)) + { + TREE_READONLY (gnu_decl) = 0; + DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; + } - /* Remove any padding so the assignment is done properly. */ - gnu_decl = maybe_padded_object (gnu_decl); + /* Remove any padding so the assignment is done properly. */ + gnu_decl = maybe_padded_object (gnu_decl); - gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init); - add_stmt_with_node (gnu_stmt, gnat_node); + gnu_stmt + = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init); + add_stmt_with_node (gnu_stmt, gnat_node); + } + + /* If this is the initialization of a (potentially) large aggregate, then + declare the dependence on the memcpy routine. */ + if (AGGREGATE_TYPE_P (type) + && (!TREE_CONSTANT (TYPE_SIZE (type)) + || compare_tree_int (TYPE_SIZE (type), 2 * BITS_PER_WORD) > 0)) + Check_Restriction_No_Dependence_On_System (Name_Memory_Copy, + gnat_node); } } @@ -9359,6 +9403,7 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64) { tree int64 = gnat_type_for_size (64, 0); + Check_Restriction_No_Dependence_On_System (Name_Arith_64, gnat_node); return convert (gnu_type, build_call_n_expr (mulv64_decl, 2, convert (int64, lhs), convert (int64, rhs))); @@ -9368,6 +9413,7 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, else if (code == MULT_EXPR && precision == 128 && BITS_PER_WORD < 128) { tree int128 = gnat_type_for_size (128, 0); + Check_Restriction_No_Dependence_On_System (Name_Arith_128, gnat_node); return convert (gnu_type, build_call_n_expr (mulv128_decl, 2, convert (int128, lhs), convert (int128, rhs))); diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 6111311..a571430 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -877,21 +877,18 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) { tree t = TREE_TYPE (decl); - /* Array and pointer types aren't tagged types in the C sense so we need - to generate a typedef in DWARF for them and make sure it is preserved, - unless the type is artificial. */ + /* Pointer types aren't named types in the C sense so we need to generate + a typedef in DWARF for them and make sure it is preserved, unless the + type is artificial. */ if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL) - && ((TREE_CODE (t) != ARRAY_TYPE && TREE_CODE (t) != POINTER_TYPE) - || DECL_ARTIFICIAL (decl))) + && (TREE_CODE (t) != POINTER_TYPE || DECL_ARTIFICIAL (decl))) ; - /* For array and pointer types, create the DECL_ORIGINAL_TYPE that will - generate the typedef in DWARF. Also do that for fat pointer types - because, even though they are tagged types in the C sense, they are - still XUP types attached to the base array type at this point. */ + /* For pointer types, create the DECL_ORIGINAL_TYPE that will generate + the typedef in DWARF. Also do that for fat pointer types because, + even though they are named types in the C sense, they are still the + XUP types created for the base array type at this point. */ else if (!DECL_ARTIFICIAL (decl) - && (TREE_CODE (t) == ARRAY_TYPE - || TREE_CODE (t) == POINTER_TYPE - || TYPE_IS_FAT_POINTER_P (t))) + && (TREE_CODE (t) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (t))) { tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; @@ -905,10 +902,6 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t)); else DECL_ORIGINAL_TYPE (decl) = t; - /* Array types need to have a name so that they can be related to - their GNAT encodings. */ - if (TREE_CODE (t) == ARRAY_TYPE && !TYPE_NAME (t)) - TYPE_NAME (t) = DECL_NAME (decl); /* Remark the canonical fat pointer type as artificial. */ if (TYPE_IS_FAT_POINTER_P (t)) TYPE_ARTIFICIAL (t) = 1; @@ -5503,8 +5496,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) expr = unchecked_convert (type, expr, notrunc_p); } - /* If we are converting from a scalar type to a type with a different size, - we need to pad to have the same size on both sides. + /* If we are converting between fixed-size types with different sizes, we + need to pad to have the same size on both sides. ??? We cannot do it unconditionally because unchecked conversions are used liberally by the front-end to implement interface thunks: @@ -5515,8 +5508,10 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) so we need to skip dereferences. */ else if (!INDIRECT_REF_P (expr) - && !AGGREGATE_TYPE_P (etype) + && TREE_CODE (expr) != STRING_CST + && !(AGGREGATE_TYPE_P (etype) && AGGREGATE_TYPE_P (type)) && ecode != UNCONSTRAINED_ARRAY_TYPE + && TREE_CONSTANT (TYPE_SIZE (etype)) && TREE_CONSTANT (TYPE_SIZE (type)) && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type)))) { @@ -5532,15 +5527,18 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty, false, false, true); expr = unchecked_convert (rec_type, expr, notrunc_p); - expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false); + expr = build3 (COMPONENT_REF, type, expr, TYPE_FIELDS (rec_type), + NULL_TREE); } } - /* Likewise if we are converting from a scalar type to a type with self- + /* Likewise if we are converting from a fixed-szie type to a type with self- referential size. We use the max size to do the padding in this case. */ else if (!INDIRECT_REF_P (expr) - && !AGGREGATE_TYPE_P (etype) + && TREE_CODE (expr) != STRING_CST + && !(AGGREGATE_TYPE_P (etype) && AGGREGATE_TYPE_P (type)) && ecode != UNCONSTRAINED_ARRAY_TYPE + && TREE_CONSTANT (TYPE_SIZE (etype)) && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (type))) { tree new_size = max_size (TYPE_SIZE (type), true); @@ -5557,7 +5555,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty, false, false, true); expr = unchecked_convert (rec_type, expr, notrunc_p); - expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false); + expr = build3 (COMPONENT_REF, type, expr, TYPE_FIELDS (rec_type), + NULL_TREE); } } diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc index 0dcc9ff..4c66a93 100644 --- a/gcc/ada/gcc-interface/utils2.cc +++ b/gcc/ada/gcc-interface/utils2.cc @@ -1134,12 +1134,17 @@ build_binary_op (enum tree_code op_code, tree result_type, else if (POINTER_TYPE_P (left_base_type) && POINTER_TYPE_P (right_base_type)) { + tree left_ref_type = TREE_TYPE (left_base_type); + tree right_ref_type = TREE_TYPE (right_base_type); + /* Anonymous access types in Ada 2005 can point to different - members of a tagged type hierarchy. */ - gcc_assert (TYPE_MAIN_VARIANT (TREE_TYPE (left_base_type)) - == TYPE_MAIN_VARIANT (TREE_TYPE (right_base_type)) - || (TYPE_ALIGN_OK (TREE_TYPE (left_base_type)) - && TYPE_ALIGN_OK (TREE_TYPE (right_base_type)))); + members of a tagged hierarchy or different function types. */ + gcc_assert (TYPE_MAIN_VARIANT (left_ref_type) + == TYPE_MAIN_VARIANT (right_ref_type) + || (TYPE_ALIGN_OK (left_ref_type) + && TYPE_ALIGN_OK (right_ref_type)) + || (TREE_CODE (left_ref_type) == FUNCTION_TYPE + && TREE_CODE (right_ref_type) == FUNCTION_TYPE)); best_type = left_base_type; } @@ -2254,6 +2259,8 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) tree malloc_ptr = build_call_n_expr (malloc_decl, 1, size_to_malloc); + Check_Restriction_No_Dependence_On_System (Name_Memory, gnat_node); + if (aligning_type) { /* Latch malloc's return value and get a pointer to the aligning field @@ -2300,7 +2307,7 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) designated by DATA_PTR using the __gnat_free entry point. */ static inline tree -maybe_wrap_free (tree data_ptr, tree data_type) +maybe_wrap_free (tree data_ptr, tree data_type, Node_Id gnat_node) { /* In the regular alignment case, we pass the data pointer straight to free. In the superaligned case, we need to retrieve the initial allocator @@ -2312,6 +2319,8 @@ maybe_wrap_free (tree data_ptr, tree data_type) tree free_ptr; + Check_Restriction_No_Dependence_On_System (Name_Memory, gnat_node); + if (data_align > system_allocator_alignment) { /* DATA_FRONT_PTR (void *) @@ -2358,7 +2367,7 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type, /* Otherwise, object to "free" or "malloc" with possible special processing for alignments stricter than what the default allocator honors. */ else if (gnu_obj) - return maybe_wrap_free (gnu_obj, gnu_type); + return maybe_wrap_free (gnu_obj, gnu_type, gnat_node); else { /* Assert that we no longer can be called with this special pool. */ diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 5c6fd92a..3217546 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -557,10 +557,14 @@ procedure Gnat1drv is Validity_Checks_On := False; Check_Validity_Of_Parameters := False; - -- Turn off style check options since we are not interested in any - -- front-end warnings when we are getting SPARK output. + -- Turn off style checks and compiler warnings in GNATprove except: + -- - elaboration warnings, which turn into errors on SPARK code + -- - suspicious contracts, which are useful for SPARK code Reset_Style_Check_Options; + Restore_Warnings (W => (Elab_Warnings => True, + Warn_On_Suspicious_Contract => True, + others => False)); -- Suppress the generation of name tables for enumerations, which are -- not needed for formal verification, and fall outside the SPARK diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b264a45..1ffc146 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Jun 24, 2022 +GNAT Reference Manual , Jul 11, 2022 AdaCore @@ -28922,9 +28922,10 @@ change. GNAT can generate code to zero-out hardware registers before returning from a subprogram. -It can be enabled with the @code{-fzero-call-used-regs} command-line -option, to affect all subprograms in a compilation, and with a -@code{Machine_Attribute} pragma, to affect only specific subprograms. +It can be enabled with the @code{-fzero-call-used-regs=@emph{choice}} +command-line option, to affect all subprograms in a compilation, and +with a @code{Machine_Attribute} pragma, to affect only specific +subprograms. @example procedure Foo; @@ -28975,10 +28976,10 @@ pragma Machine_Attribute (Var, "strub"); -- scrubbing of the stack space used by that subprogram. @end example -There are also @code{-fstrub} command-line options to control -default settings. For usage and more details on the command-line -option, on the @code{strub} attribute, and their use with other -programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. +There are also @code{-fstrub=@emph{choice}} command-line options to +control default settings. For usage and more details on the +command-line options, on the @code{strub} attribute, and their use with +other programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. Note that Ada secondary stacks are not scrubbed. The restriction @code{No_Secondary_Stack} avoids their use, and thus their accidental diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index cfd9a87..64ebd95 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 , Jun 24, 2022 +GNAT User's Guide for Native Platforms , Jul 11, 2022 AdaCore @@ -7120,6 +7120,21 @@ If @code{--version} was not used, display usage, then exit disregarding all other options. @end table +@geindex -P (gnatmake) + + +@table @asis + +@item @code{-P@emph{project}} + +Build GNAT project file @code{project} using GPRbuild. When this switch is +present, all other command-line switches are treated as GPRbuild switches +and not @code{gnatmake} switches. +@end table + +@c -- Comment: +@c :ref:`gnatmake_and_Project_Files`. + @geindex --GCC=compiler_name (gnatmake) @@ -7620,19 +7635,6 @@ This switch cannot be used when invoking @code{gnatmake} with several Same as @code{--create-missing-dirs} @end table -@geindex -P (gnatmake) - - -@table @asis - -@item @code{-P@emph{project}} - -Use project file @code{project}. Only one such switch can be used. -@end table - -@c -- Comment: -@c :ref:`gnatmake_and_Project_Files`. - @geindex -q (gnatmake) diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 7244526..6e7e722 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -189,7 +189,6 @@ procedure Gnatls is -- Print usage message procedure Output_License_Information; - pragma No_Return (Output_License_Information); -- Output license statement, and if not found, output reference to COPYING function Image (Restriction : Restriction_Id) return String; @@ -894,8 +893,6 @@ procedure Gnatls is & " for license terms."); Write_Eol; end case; - - Exit_Program (E_Success); end Output_License_Information; ------------------- diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index 58ae104..34575c2 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -93,8 +93,8 @@ package body GPrep is procedure Display_Copyright; -- Display the copyright notice - procedure Post_Scan; - -- Null procedure, needed by instantiation of Scng below + procedure Post_Scan is null; + -- Needed by instantiation of Scng below package Scanner is new Scng (Post_Scan, @@ -327,15 +327,6 @@ package body GPrep is New_Line (Outfile.all); end New_EOL_To_Outfile; - --------------- - -- Post_Scan -- - --------------- - - procedure Post_Scan is - begin - null; - end Post_Scan; - ---------------------------- -- Preprocess_Infile_Name -- ---------------------------- diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index b6a7bde..343a9db 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -605,6 +605,7 @@ package body Impunit is -- GNAT Defined Additions to Ada 2012 -- ---------------------------------------- + ("a-cfidll", F), -- Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists ("a-cfinse", F), -- Ada.Containers.Functional_Infinite_Sequences ("a-cfinve", F), -- Ada.Containers.Formal_Indefinite_Vectors ("a-coboho", F), -- Ada.Containers.Bounded_Holders diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 00c1e03..e32df68 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -32,7 +32,6 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; -with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; @@ -1107,7 +1106,6 @@ package body Inline is procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); - Analysis_Status : constant Boolean := Full_Analysis; Original_Body : Node_Id; Body_To_Analyze : Node_Id; Max_Size : constant := 10; @@ -1419,12 +1417,7 @@ package body Inline is Append (Body_To_Analyze, Declarations (N)); end if; - -- The body to inline is preanalyzed. In GNATprove mode we must disable - -- full analysis as well so that light expansion does not take place - -- either, and name resolution is unaffected. - - Expander_Mode_Save_And_Set (False); - Full_Analysis := False; + Start_Generic; Analyze (Body_To_Analyze); Push_Scope (Defining_Entity (Body_To_Analyze)); @@ -1432,8 +1425,7 @@ package body Inline is End_Scope; Remove (Body_To_Analyze); - Expander_Mode_Restore; - Full_Analysis := Analysis_Status; + End_Generic; -- Restore environment if previously saved @@ -4648,6 +4640,7 @@ package body Inline is return Present (Declarations (N)) and then Present (First (Declarations (N))) + and then Nkind (First (Declarations (N))) = N_Object_Declaration and then Entity (Expression (Return_Statement)) = Defining_Identifier (First (Declarations (N))); end if; diff --git a/gcc/ada/libgnarl/a-reatim.ads b/gcc/ada/libgnarl/a-reatim.ads index 4b8f7aa..dee20e9 100644 --- a/gcc/ada/libgnarl/a-reatim.ads +++ b/gcc/ada/libgnarl/a-reatim.ads @@ -41,6 +41,7 @@ package Ada.Real_Time with Abstract_State => (Clock_Time with Synchronous), Initializes => Clock_Time is + pragma Annotate (GNATprove, Always_Return, Real_Time); pragma Compile_Time_Error (Duration'Size /= 64, diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb index 5bd6656..dc0ce37 100644 --- a/gcc/ada/libgnarl/s-solita.adb +++ b/gcc/ada/libgnarl/s-solita.adb @@ -188,7 +188,14 @@ package body System.Soft_Links.Tasking is -- fall-back handler applies only to the dependent tasks of the task". if Self_Id.Common.Specific_Handler /= null then - Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); + begin + Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); + exception + -- RM-C.7.3(16) requires all exceptions raised here to be ignored + + when others => + null; + end; end if; end Task_Termination_Handler_T; diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 2e6a0bb..b313b15 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -1168,7 +1168,7 @@ package System.Tasking is -- -- Protection: Self.L. Once a task has set Self.Stage to Completing, it -- has exclusive access to this field. - end record; + end record; -- Ada_Task_Control_Block -------------------- -- Initialization -- diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index d6ed99c..8ba852e 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -1307,10 +1307,8 @@ package body System.Tasking.Stages is if TH /= null then begin TH.all (Cause, Self_ID, EO); - exception - - -- RM-C.7.3 requires all exceptions raised here to be ignored + -- RM-C.7.3(16) requires all exceptions raised here to be ignored when others => null; diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index 10be7ab..78343a0 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -364,10 +364,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index 6891a2f..c62d451 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -439,10 +439,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads index 351014d..7c6d971 100644 --- a/gcc/ada/libgnat/a-cbhase.ads +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -596,10 +596,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads index 2448eac..89d5cdf 100644 --- a/gcc/ada/libgnat/a-cbmutr.ads +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -386,10 +386,7 @@ private Item : out Reference_Type); for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads index 5b0ed73..af69feb 100644 --- a/gcc/ada/libgnat/a-cborma.ads +++ b/gcc/ada/libgnat/a-cborma.ads @@ -341,10 +341,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads index 53acf35..0b7e86f 100644 --- a/gcc/ada/libgnat/a-cborse.ads +++ b/gcc/ada/libgnat/a-cborse.ads @@ -435,10 +435,10 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads index abfd011..bfe10ee 100644 --- a/gcc/ada/libgnat/a-cdlili.ads +++ b/gcc/ada/libgnat/a-cdlili.ads @@ -374,10 +374,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index ff7d2d8..01e7db2 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -37,8 +37,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index bf1e85f..8cb7488 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -62,8 +62,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 80ce948..248a0ac 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -62,8 +62,10 @@ generic Right : Element_Type) return Boolean is "="; package Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cfidll.adb b/gcc/ada/libgnat/a-cfidll.adb new file mode 100644 index 0000000..17e48d2 --- /dev/null +++ b/gcc/ada/libgnat/a-cfidll.adb @@ -0,0 +1,2054 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-2022, 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + +with System; use type System.Address; + +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + +package body Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with + SPARK_Mode => Off +is + -- Convert Count_Type to Big_Integer + + package Conversions is new Signed_Conversions (Int => Count_Type); + use Conversions; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type); + + procedure Free (Container : in out List; X : Count_Type); + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type); + + function Vet (L : List; Position : Cursor) return Boolean with Inline; + + procedure Resize (Container : in out List) with + -- Add more room in the internal array + + Global => null, + Pre => Container.Nodes = null + or else Length (Container) = Container.Nodes'Length, + Post => Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old; + + procedure Finalize_Element is new Ada.Unchecked_Deallocation + (Object => Element_Type, + Name => Element_Access); + + procedure Finalize_Nodes is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left : List; Right : List) return Boolean is + LI : Count_Type; + RI : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + LI := Left.First; + RI := Right.First; + while LI /= 0 loop + if Left.Nodes (LI).Element.all /= Right.Nodes (RI).Element.all then + return False; + end if; + + LI := Left.Nodes (LI).Next; + RI := Right.Nodes (RI).Next; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out List) is + N_Src : Node_Array_Access renames Container.Nodes; + N_Tar : Node_Array_Access; + + begin + if N_Src = null then + return; + end if; + + if Container.Length = 0 then + Container.Nodes := null; + Container.Free := -1; + return; + end if; + + N_Tar := new Node_Array (1 .. N_Src'Length); + + for X in 1 .. Count_Type (N_Src'Length) loop + N_Tar (X) := N_Src (X); + if N_Src (X).Element /= null + then + N_Tar (X).Element := new Element_Type'(N_Src (X).Element.all); + end if; + end loop; + + N_Src := N_Tar; + + end Adjust; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Container.Nodes = null + or else Length (Container) = Container.Nodes'Length + then + Resize (Container); + end if; + + if Container.Free >= 0 then + New_Node := Container.Free; + Container.Free := N (New_Node).Next; + else + New_Node := abs Container.Free; + Container.Free := Container.Free - 1; + end if; + + N (New_Node).Element := null; + end Allocate; + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + Allocate (Container, New_Node); + + N (New_Node).Element := new Element_Type'(New_Item); + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, No_Element, New_Item, 1); + end Append; + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + N : Node_Array_Access renames Source.Nodes; + J : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + J := Source.First; + while J /= 0 loop + Append (Target, N (J).Element.all); + J := N (J).Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + while Container.Length > 1 loop + X := Container.First; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : List; + Position : Cursor) return not null access constant Element_Type + is + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List + is + N : Count_Type; + P : List; + + begin + if Source.Nodes = null then + return P; + end if; + + P.Nodes := new Node_Array (1 .. Source.Nodes'Length); + + N := 1; + while N <= Source.Nodes'Length loop + P.Nodes (N).Prev := Source.Nodes (N).Prev; + P.Nodes (N).Next := Source.Nodes (N).Next; + if Source.Nodes (N).Element /= null then + P.Nodes (N).Element := + new Element_Type'(Source.Nodes (N).Element.all); + end if; + N := N + 1; + end loop; + + P.Free := Source.Free; + P.Length := Source.Length; + P.First := Source.First; + P.Last := Source.Last; + + return P; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out List; Position : in out Cursor) is + begin + Delete + (Container => Container, + Position => Position, + Count => 1); + end Delete; + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if not Has_Element (Container => Container, + Position => Position) + then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + pragma Assert (N (Position.Node).Prev >= 0); + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out List) is + begin + Delete_First + (Container => Container, + Count => 1); + end Delete_First; + + procedure Delete_First (Container : in out List; Count : Count_Type) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out List) is + begin + Delete_Last + (Container => Container, + Count => 1); + end Delete_Last; + + procedure Delete_Last (Container : in out List; Count : Count_Type) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : List; + Position : Cursor) return Element_Type + is + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element.all; + end Element; + + ---------------- + -- Empty_List -- + ---------------- + + function Empty_List return List is + ((Controlled with others => <>)); + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out List) is + X : Count_Type := Container.First; + N : Node_Array_Access renames Container.Nodes; + begin + + if N = null then + return; + end if; + + while X /= 0 loop + Finalize_Element (N (X).Element); + X := N (X).Next; + end loop; + + Finalize_Nodes (N); + + Container.Free := 0; + Container.Last := 0; + Container.First := 0; + Container.Length := 0; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + From : Count_Type := Position.Node; + + begin + if From = 0 and Container.Length = 0 then + return No_Element; + end if; + + if From = 0 then + From := Container.First; + end if; + + if Position.Node /= 0 and then not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + while From /= 0 loop + if Container.Nodes (From).Element.all = Item then + return (Node => From); + end if; + + From := Container.Nodes (From).Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + F : constant Count_Type := Container.First; + begin + if F = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (F).Element.all; + end if; + end First_Element; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : List) is null; + + ------------------------- + -- M_Elements_In_Union -- + ------------------------- + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + is + Elem : Element_Type; + + begin + for Index in 1 .. M.Length (Container) loop + Elem := Element (Container, Index); + + if not M.Contains (Left, 1, M.Length (Left), Elem) + and then not M.Contains (Right, 1, M.Length (Right), Elem) + then + return False; + end if; + end loop; + + return True; + end M_Elements_In_Union; + + ------------------------- + -- M_Elements_Included -- + ------------------------- + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + is + begin + for I in L_Fst .. L_Lst loop + declare + Found : Boolean := False; + J : Count_Type := R_Fst - 1; + + begin + while not Found and J < R_Lst loop + J := J + 1; + if Element (Left, I) = Element (Right, J) then + Found := True; + end if; + end loop; + + if not Found then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_Included; + + ------------------------- + -- M_Elements_Reversed -- + ------------------------- + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + is + L : constant Count_Type := M.Length (Left); + + begin + if L /= M.Length (Right) then + return False; + end if; + + for I in 1 .. L loop + if Element (Left, I) /= Element (Right, L - I + 1) then + return False; + end if; + end loop; + + return True; + end M_Elements_Reversed; + + ------------------------ + -- M_Elements_Swapped -- + ------------------------ + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + is + begin + if M.Length (Left) /= M.Length (Right) + or else Element (Left, X) /= Element (Right, Y) + or else Element (Left, Y) /= Element (Right, X) + then + return False; + end if; + + for I in 1 .. M.Length (Left) loop + if I /= X and then I /= Y + and then Element (Left, I) /= Element (Right, I) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Swapped; + + ----------- + -- Model -- + ----------- + + function Model (Container : List) return M.Sequence is + Position : Count_Type := Container.First; + R : M.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := M.Add (R, Container.Nodes (Position).Element.all); + Position := Container.Nodes (Position).Next; + end loop; + + return R; + end Model; + + ----------------------- + -- Mapping_Preserved -- + ----------------------- + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > M.Length (M_Left) + or else P.Get (P_Right, C) > M.Length (M_Right) + or else M.Get (M_Left, P.Get (P_Left, C)) /= + M.Get (M_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + for C of P_Right loop + if not P.Has_Key (P_Left, C) then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ------------------------- + -- P_Positions_Shifted -- + ------------------------- + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + Count + then + return False; + end if; + + else + if P.Has_Key (Small, Cu) then + return False; + end if; + end if; + end; + end loop; + + return True; + end P_Positions_Shifted; + + ------------------------- + -- P_Positions_Swapped -- + ------------------------- + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + is + begin + if not P.Has_Key (Left, X) + or not P.Has_Key (Left, Y) + or not P.Has_Key (Right, X) + or not P.Has_Key (Right, Y) + then + return False; + end if; + + if P.Get (Left, X) /= P.Get (Right, Y) + or P.Get (Left, Y) /= P.Get (Right, X) + then + return False; + end if; + + for C of Left loop + if not P.Has_Key (Right, C) then + return False; + end if; + end loop; + + for C of Right loop + if not P.Has_Key (Left, C) + or else (C /= X + and C /= Y + and P.Get (Left, C) /= P.Get (Right, C)) + then + return False; + end if; + end loop; + + return True; + end P_Positions_Swapped; + + --------------------------- + -- P_Positions_Truncated -- + --------------------------- + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + return False; + + elsif P.Has_Key (Small, Cu) then + return False; + end if; + end; + end loop; + + return True; + end P_Positions_Truncated; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : List) return P.Map is + I : Count_Type := 1; + Position : Count_Type := Container.First; + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = To_Big_Integer (I)); + Position := Container.Nodes (Position).Next; + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (Container : in out List; X : Count_Type) is + pragma Assert (X > 0); + pragma Assert (X <= Container.Nodes'Length); + + N : Node_Array_Access renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if N (X).Element /= null then + Finalize_Element (N (X).Element); + end if; + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + else + Container.Free := abs Container.Free; + + for J in Container.Free .. Container.Nodes'Length loop + N (J).Next := J + 1; + end loop; + + N (Container.Nodes'Length).Next := 0; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting with SPARK_Mode => Off is + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Elements_Sorted -- + ----------------------- + + function M_Elements_Sorted (Container : M.Sequence) return Boolean is + begin + if M.Length (Container) = 0 then + return True; + end if; + + declare + E1 : Element_Type := Element (Container, 1); + + begin + for I in 2 .. M.Length (Container) loop + declare + E2 : constant Element_Type := Element (Container, I); + + begin + if E2 < E1 then + return False; + end if; + + E1 := E2; + end; + end loop; + end; + + return True; + end M_Elements_Sorted; + + end Formal_Model; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array_Access renames Container.Nodes; + Node : Count_Type := Container.First; + + begin + for J in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element.all < Nodes (Node).Element.all + then + return False; + else + Node := Nodes (Node).Next; + end if; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target : in out List; Source : in out List) is + LN : Node_Array_Access renames Target.Nodes; + RN : Node_Array_Access renames Source.Nodes; + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= 0 loop + pragma Assert + (RN (RI.Node).Next = 0 + or else not (RN (RN (RI.Node).Next).Element.all < + RN (RI.Node).Element.all)); + + if LI.Node = 0 then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert + (LN (LI.Node).Next = 0 + or else not (LN (LN (LI.Node).Next).Element.all < + LN (LI.Node).Element.all)); + + if RN (RI.Node).Element.all < LN (LI.Node).Element.all then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RN (RI.Node).Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LN (LI.Node).Next; + end if; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element.all < N (R).Element.all); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : List; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return False; + end if; + + return Container.Nodes (Position.Node).Prev /= -1; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + is + J : Count_Type; + + begin + if Before.Node /= 0 then + pragma Assert (Vet (Container, Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := (Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + is + begin + Insert + (Container => Container, + Before => Before, + New_Item => New_Item, + Position => Position, + Count => 1); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, 1); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + Container.Last := New_Node; + + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return (Node => Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + L : constant Count_Type := Container.Last; + + begin + if L = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (L).Element.all; + end if; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + N : Node_Array_Access renames Source.Nodes; + + procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + begin + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + if Source.Length = 0 then + return; + end if; + + -- Make sure that Target is large enough + + if Target.Nodes = null + or else Target.Nodes'Length < Source.Length + then + if Target.Nodes /= null then + Finalize_Node_Array (Target.Nodes); + end if; + Target.Nodes := new Node_Array (1 .. Source.Length); + end if; + + -- Copy first element from Source to Target + + Target.First := 1; + + Target.Nodes (1).Prev := 0; + Target.Nodes (1).Element := N (Source.First).Element; + N (Source.First).Element := null; + + -- Copy the other elements + + declare + X_Src : Count_Type := N (Source.First).Next; + X_Tar : Count_Type := 2; + + begin + while X_Src /= 0 loop + Target.Nodes (X_Tar).Prev := X_Tar - 1; + Target.Nodes (X_Tar - 1).Next := X_Tar; + + Target.Nodes (X_Tar).Element := N (X_Src).Element; + N (X_Src).Element := null; + + X_Src := N (X_Src).Next; + X_Tar := X_Tar + 1; + end loop; + end; + + Target.Last := Source.Length; + Target.Length := Source.Length; + Target.Nodes (Target.Last).Next := 0; + + -- Set up the free list + + Target.Free := -Source.Length - 1; + + -- It is possible to Clear Source because the Element accesses were + -- set to null. + + Clear (Source); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : List; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + function Next (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Next); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, First (Container), New_Item, 1); + end Prepend; + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : List; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Prev); + end Previous; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : not null access List; + Position : Cursor) return not null access Element_Type + is + begin + if not Has_Element (Container.all, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); + + Finalize_Element (Container.Nodes (Position.Node).Element); + Container.Nodes (Position.Node).Element := new Element_Type'(New_Item); + end Replace_Element; + + ------------ + -- Resize -- + ------------ + + procedure Resize (Container : in out List) is + Min_Size : constant Count_Type := 100; + begin + if Container.Nodes = null then + Container.Nodes := new Node_Array (1 .. Min_Size); + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + Container.Free := -1; + + return; + end if; + + if Container.Length /= Container.Nodes'Length then + raise Program_Error with "List must be at size max to resize"; + end if; + + declare + procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + New_Size : constant Count_Type := + (if Container.Nodes'Length > Count_Type'Last / 2 + then Count_Type'Last + else 2 * Container.Nodes'Length); + New_Nodes : Node_Array_Access; + + begin + New_Nodes := + new Node_Array (1 .. Count_Type'Max (New_Size, Min_Size)); + + New_Nodes (1 .. Container.Nodes'Length) := + Container.Nodes (1 .. Container.Nodes'Length); + + Container.Free := -Container.Nodes'Length - 1; + + Finalize_Node_Array (Container.Nodes); + Container.Nodes := New_Nodes; + end; + end Resize; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L : Count_Type; R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L : Count_Type; R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + CFirst : Count_Type := Position.Node; + + begin + if CFirst = 0 then + CFirst := Container.Last; + end if; + + if Container.Length = 0 then + return No_Element; + else + while CFirst /= 0 loop + if Container.Nodes (CFirst).Element.all = Item then + return (Node => CFirst); + else + CFirst := Container.Nodes (CFirst).Prev; + end if; + end loop; + + return No_Element; + end if; + end Reverse_Find; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + SN : Node_Array_Access renames Source.Nodes; + TN : Node_Array_Access renames Target.Nodes; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Before.Node /= 0 then + pragma Assert (Vet (Target, Before), "bad cursor in Splice"); + end if; + + if Is_Empty (Source) then + return; + end if; + + pragma Assert (SN (Source.First).Prev = 0); + pragma Assert (SN (Source.Last).Next = 0); + + declare + X : Count_Type; + + begin + while not Is_Empty (Source) loop + Allocate (Target, X); + + TN (X).Element := SN (Source.Last).Element; + + -- Insert the new node in Target + + Insert_Internal (Target, Before.Node, X); + + -- Free the last node of Source + + SN (Source.Last).Element := null; + Delete_Last (Source); + end loop; + end; + + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); + + declare + X : Count_Type; + + begin + Allocate (Target, X); + + Target.Nodes (X).Element := Source.Nodes (Position.Node).Element; + + -- Insert the new node in Target + + Insert_Internal (Target, Before.Node, X); + + -- Free the node at position Position in Source + + Source.Nodes (Position.Node).Element := null; + Delete (Source, Position); + + Position := (Node => X); + end; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Before.Node /= 0 then + pragma Assert + (Vet (Container, Before), "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + is + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap"); + + declare + NN : Node_Array_Access renames Container.Nodes; + NI : Node_Type renames NN (I.Node); + NJ : Node_Type renames NN (J.Node); + + EI_Copy : constant Element_Access := NI.Element; + + begin + NI.Element := NJ.Element; + NJ.Element := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + is + I_Next : Cursor; + J_Next : Cursor; + + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); + + I_Next := Next (Container, I); + + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + J_Next := Next (Container, J); + + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end if; + end Swap_Links; + + --------- + -- Vet -- + --------- + + function Vet (L : List; Position : Cursor) return Boolean is + N : Node_Array_Access renames L.Nodes; + begin + if not Container_Checks'Enabled then + return True; + end if; + + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > L.Nodes'Length then + return False; + end if; + + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Nodes'Length + then + return False; + end if; + + if N (Position.Node).Next > L.Nodes'Length then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 and then Position.Node /= L.First then + return False; + end if; + + if N (Position.Node).Next = 0 and then Position.Node /= L.Last then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end Vet; + +end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfidll.ads b/gcc/ada/libgnat/a-cfidll.ads new file mode 100644 index 0000000..c4d244a --- /dev/null +++ b/gcc/ada/libgnat/a-cfidll.ads @@ -0,0 +1,1670 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2022, 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Functional_Vectors; +with Ada.Containers.Functional_Maps; +private with Ada.Finalization; + +generic + type Element_Type is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with + SPARK_Mode +is + -- Contracts in this unit are meant for analysis only, not for run-time + -- checking. + + pragma Assertion_Policy (Pre => Ignore); + pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); + pragma Annotate (CodePeer, Skip_Analysis); + + type List is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Element), + Default_Initial_Condition => Is_Empty (List); + + type Cursor is record + Node : Count_Type := 0; + end record; + + No_Element : constant Cursor := Cursor'(Node => 0); + + function Length (Container : List) return Count_Type with + Global => null; + + function Empty_List return List with + Global => null, + Post => Length (Empty_List'Result) = 0; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Vectors + (Index_Type => Positive_Count_Type, + Element_Type => Element_Type); + + function "=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."="; + + function "<" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<"; + + function "<=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<="; + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + -- The elements of Container are contained in either Left or Right + with + Global => null, + Post => + M_Elements_In_Union'Result = + (for all I in 1 .. M.Length (Container) => + (for some J in 1 .. M.Length (Left) => + Element (Container, I) = Element (Left, J)) + or (for some J in 1 .. M.Length (Right) => + Element (Container, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + -- The elements of the slice from L_Fst to L_Lst in Left are contained + -- in the slide from R_Fst to R_Lst in Right. + with + Global => null, + Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), + Post => + M_Elements_Included'Result = + (for all I in L_Fst .. L_Lst => + (for some J in R_Fst .. R_Lst => + Element (Left, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + -- Right is Left in reverse order + with + Global => null, + Post => + M_Elements_Reversed'Result = + (M.Length (Left) = M.Length (Right) + and (for all I in 1 .. M.Length (Left) => + Element (Left, I) = + Element (Right, M.Length (Left) - I + 1)) + and (for all I in 1 .. M.Length (Left) => + Element (Right, I) = + Element (Left, M.Length (Left) - I + 1))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + -- Elements stored at X and Y are reversed in Left and Right + with + Global => null, + Pre => X <= M.Length (Left) and Y <= M.Length (Left), + Post => + M_Elements_Swapped'Result = + (M.Length (Left) = M.Length (Right) + and Element (Left, X) = Element (Right, Y) + and Element (Left, Y) = Element (Right, X) + and M.Equal_Except (Left, Right, X, Y)); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Global => null, + Post => + P_Positions_Shifted'Result = + + -- Big contains all cursors of Small + + (P.Keys_Included (Small, Big) + + -- Cursors located before Cut are not moved, cursors located + -- after are shifted by Count. + + and (for all I of Small => + (if P.Get (Small, I) < Cut then + P.Get (Big, I) = P.Get (Small, I) + else + P.Get (Big, I) - Count = P.Get (Small, I))) + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + -- Left and Right contain the same cursors, but the positions of X and Y + -- are reversed. + with + Ghost, + Global => null, + Post => + P_Positions_Swapped'Result = + (P.Same_Keys (Left, Right) + and P.Elements_Equal_Except (Left, Right, X, Y) + and P.Has_Key (Left, X) + and P.Has_Key (Left, Y) + and P.Get (Left, X) = P.Get (Right, Y) + and P.Get (Left, Y) = P.Get (Right, X)); + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Ghost, + Global => null, + Post => + P_Positions_Truncated'Result = + + -- Big contains all cursors of Small at the same position + + (Small <= Big + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Left and Right contain the same cursors + + P.Same_Keys (P_Left, P_Right) + + -- Mappings from cursors to elements induced by M_Left, P_Left + -- and M_Right, P_Right are the same. + + and (for all C of P_Left => + M.Get (M_Left, P.Get (P_Left, C)) = + M.Get (M_Right, P.Get (P_Right, C)))); + + function Model (Container : List) return M.Sequence with + -- The high-level model of a list is a sequence of elements. Cursors are + -- not represented in this model. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); + + function Positions (Container : List) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and map them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : List) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access to the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level cursor-aware view of a container to a high-level + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Elt of Model (Container) => + (for some I of Positions (Container) => + M.Get (Model (Container), P.Get (Positions (Container), I)) = + Elt)); + + function Element + (S : M.Sequence; + I : Count_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function "=" (Left, Right : List) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function Is_Empty (Container : List) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out List) with + Global => null, + Post => Length (Container) = 0; + + procedure Assign (Target : in out List; Source : List) with + Global => null, + Post => Model (Target) = Model (Source); + + function Copy (Source : List) return List with + Global => null, + Post => + Model (Copy'Result) = Model (Source) + and Positions (Copy'Result) = Positions (Source); + + function Element + (Container : List; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = + Element (Model (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old + + -- Cursors are preserved + + and Positions (Container)'Old = Positions (Container) + + -- The element at the position of Position in Container is New_Item + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- Other elements are preserved + + and M.Equal_Except + (Model (Container)'Old, + Model (Container), + P.Get (Positions (Container), Position)); + + function At_End (E : access constant List) return access constant List + is (E) + with Ghost, + Annotate => (GNATprove, At_End_Borrow); + + function At_End + (E : access constant Element_Type) return access constant Element_Type + is (E) + with Ghost, + Annotate => (GNATprove, At_End_Borrow); + + function Constant_Reference + (Container : List; + Position : Cursor) return not null access constant Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Constant_Reference'Result.all = + Element (Model (Container), P.Get (Positions (Container), Position)); + + function Reference + (Container : not null access List; + Position : Cursor) return not null access Element_Type + with + Global => null, + Pre => Has_Element (Container.all, Position), + Post => + Length (Container.all) = Length (At_End (Container).all) + + -- Cursors are preserved + + and Positions (Container.all) = Positions (At_End (Container).all) + + -- Container will have Result.all at position Position + + and At_End (Reference'Result).all = + Element (Model (At_End (Container).all), + P.Get (Positions (At_End (Container).all), Position)) + + -- All other elements are preserved + + and M.Equal_Except + (Model (Container.all), + Model (At_End (Container).all), + P.Get (Positions (At_End (Container).all), Position)); + + procedure Move (Target : in out List; Source : in out List) with + Global => null, + Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + 1, + Contract_Cases => + (Before = No_Element => + + -- Positions contains a new mapping from the last cursor of + -- Container to its length. + + P.Get (Positions (Container), Last (Container)) = Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at the previous position of Before in + -- Container. + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = New_Item + + -- A new cursor has been inserted at position Before in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before))); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Count_Type'Last - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Before = No_Element => + + -- The elements of Container are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Before + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => + P.Get (Positions (Container)'Old, Before) - 1 + Count, + Item => New_Item) + + -- Count cursors have been inserted at position Before in + -- Container. + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before), + Count => Count)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + with + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + and P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = Length (Container) + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at Position in Container + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- A new cursor has been inserted at position Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Count_Type'Last - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Count = 0 => + Position = Before + and Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + others => + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = + Length (Container)'Old + 1 + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Position + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => + P.Get (Positions (Container), Position) - 1 + Count, + Item => New_Item) + + -- Count cursor have been inserted at Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position), + Count => Count)); + + procedure Prepend (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Count_Type'Last, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is the first element of Container + + and Element (Model (Container), 1) = New_Item + + -- A new cursor has been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Count_Type'Last - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => Count) + + -- Container starts with Count times New_Item + + and M.Constant_Range + (Container => Model (Container), + Fst => 1, + Lst => Count, + Item => New_Item) + + -- Count cursors have been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1, + Count => Count); + + procedure Append (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Count_Type'Last, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions contains a new mapping from the last cursor of Container + -- to its length. + + and P.Get (Positions (Container), Last (Container)) = + Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Count_Type'Last - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- The elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count); + + procedure Delete (Container : in out List; Position : in out Cursor) with + Global => null, + Depends => (Container =>+ Position, Position => null), + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => 1) + + -- Position has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old)); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) in + Length (Container)'Old - Count .. Length (Container)'Old + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), + + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) - Count < P.Get (Positions (Container), Position) => + Length (Container) = + P.Get (Positions (Container)'Old, Position'Old) - 1 + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count), + + others => + Length (Container) = Length (Container)'Old - Count + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => Count) + + -- Count cursors have been removed from Container at Position + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count)); + + procedure Delete_First (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => 1) + + -- The first cursor of Container has been removed + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1); + + procedure Delete_First (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- Elements of Container are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => Count) + + -- The first Count cursors have been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1, + Count => Count)); + + procedure Delete_Last (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- The last cursor of Container has been removed + + and not P.Has_Key (Positions (Container), Last (Container)'Old) + + -- Other cursors are still valid + + and P.Keys_Included_Except + (Left => Positions (Container)'Old, + Right => Positions (Container)'Old, + New_Key => Last (Container)'Old) + + -- The positions of other cursors are preserved + + and Positions (Container) <= Positions (Container)'Old; + + procedure Delete_Last (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => Length (Container) + 1, + Count => Count)); + + procedure Reverse_Elements (Container : in out List) with + Global => null, + Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container)'Old, + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + + and Positions (Container) = Positions (Container)'Old; + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container'Old), + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + and P_Positions_Swapped + (Positions (Container)'Old, Positions (Container), I, J); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + -- Target and Source should not be aliased + with + Global => null, + Pre => + Length (Source) <= Count_Type'Last - Length (Target) + and then (Has_Element (Target, Before) or else Before = No_Element), + Post => + Length (Source) = 0 + and Length (Target) = Length (Target)'Old + Length (Source)'Old, + Contract_Cases => + (Before = No_Element => + + -- The elements of Target are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => Length (Target)'Old) + + -- The elements of Source are appended to target, the order is not + -- specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => Length (Target)'Old + 1, + R_Lst => Length (Target)) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => Length (Target)'Old + 1, + L_Lst => Length (Target), + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Cursors have been inserted at the end of Target + + and P_Positions_Truncated + (Positions (Target)'Old, + Positions (Target), + Cut => Length (Target)'Old + 1, + Count => Length (Source)'Old), + + others => + + -- The elements of Target located before Before are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target)'Old, Before) - 1) + + -- The elements of Source are inserted before Before, the order is + -- not specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => P.Get (Positions (Target)'Old, Before), + R_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => P.Get (Positions (Target)'Old, Before), + L_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old, + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Other elements are shifted by the length of Source + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target)'Old, Before), + Lst => Length (Target)'Old, + Offset => Length (Source)'Old) + + -- Cursors have been inserted at position Before in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target)'Old, Before), + Count => Length (Source)'Old)); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + -- Target and Source should not be aliased + with + Global => null, + Pre => + (Has_Element (Target, Before) or else Before = No_Element) + and then Has_Element (Source, Position) + and then Length (Target) < Count_Type'Last, + Post => + Length (Target) = Length (Target)'Old + 1 + and Length (Source) = Length (Source)'Old - 1 + + -- The elements of Source located before Position are preserved + + and M.Range_Equal + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => 1, + Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, + Lst => Length (Source)'Old, + Offset => -1) + + -- Position has been removed from Source + + and P_Positions_Shifted + (Positions (Source), + Positions (Source)'Old, + Cut => P.Get (Positions (Source)'Old, Position'Old)) + + -- Positions is valid in Target and it is located either before + -- Before if it is valid in Target or at the end if it is No_Element. + + and P.Has_Key (Positions (Target), Position) + and (if Before = No_Element then + P.Get (Positions (Target), Position) = Length (Target) + else + P.Get (Positions (Target), Position) = + P.Get (Positions (Target)'Old, Before)) + + -- The elements of Target located before Position are preserved + + and M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target), Position), + Lst => Length (Target)'Old, + Offset => 1) + + -- The element located at Position in Source is moved to Target + + and Element (Model (Target), + P.Get (Positions (Target), Position)) = + Element (Model (Source)'Old, + P.Get (Positions (Source)'Old, Position'Old)) + + -- A new cursor has been inserted at position Position in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target), Position)); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + with + Global => null, + Pre => + (Has_Element (Container, Before) or else Before = No_Element) + and then Has_Element (Container, Position), + Post => Length (Container) = Length (Container)'Old, + Contract_Cases => + (Before = Position => + Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + Before = No_Element => + + -- The elements located before Position are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => Length (Container)'Old, + Offset => -1) + + -- The last element of Container is the one that was previously at + -- Position. + + and Element (Model (Container), + Length (Container)) = + Element (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)), + + others => + + -- The elements located before Position and Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => + Count_Type'Min + (P.Get (Positions (Container)'Old, Position) - 1, + P.Get (Positions (Container)'Old, Before) - 1)) + + -- The elements located after Position and Before are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => + Count_Type'Max + (P.Get (Positions (Container)'Old, Position) + 1, + P.Get (Positions (Container)'Old, Before) + 1), + Lst => Length (Container)) + + -- The elements located after Before and before Position are + -- shifted by 1 to the right. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before) + 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1, + Offset => 1) + + -- The elements located after Position and before Before are + -- shifted by 1 to the left. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1, + Offset => -1) + + -- The element previously at Position is now before Before + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = + Element + (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container))); + + function First (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function First_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => First_Element'Result = M.Get (Model (Container), 1); + + function Last (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + Last'Result = No_Element, + + others => + Has_Element (Container, Last'Result) + and P.Get (Positions (Container), Last'Result) = + Length (Container)); + + function Last_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = M.Get (Model (Container), Length (Container)); + + function Next (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Previous (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Previous'Result = No_Element, + + others => + Has_Element (Container, Previous'Result) + and then P.Get (Positions (Container), Previous'Result) = + P.Get (Positions (Container), Position) - 1); + + procedure Previous (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) - 1); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container after Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => Length (Container), + Item => Item) + => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Find'Result)) = Item + + -- The result of Find is located after Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Find'Result) >= + P.Get (Positions (Container), Position)) + + -- It is the first occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => + P.Get (Positions (Container), Find'Result) - 1, + Item => Item)); + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container before Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item) + => + Reverse_Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Reverse_Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Reverse_Find'Result)) = Item + + -- The result of Find is located before Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Reverse_Find'Result) <= + P.Get (Positions (Container), Position)) + + -- It is the last occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + P.Get (Positions (Container), + Reverse_Find'Result) + 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item)); + + function Contains + (Container : List; + Item : Element_Type) return Boolean + with + Global => null, + Post => + Contains'Result = M.Contains (Container => Model (Container), + Fst => 1, + Lst => Length (Container), + Item => Item); + + function Has_Element + (Container : List; + Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + + package Generic_Sorting with SPARK_Mode is + + package Formal_Model with Ghost is + function M_Elements_Sorted (Container : M.Sequence) return Boolean + with + Global => null, + Post => + M_Elements_Sorted'Result = + (for all I in 1 .. M.Length (Container) => + (for all J in I .. M.Length (Container) => + not (Element (Container, J) < Element (Container, I)))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); + + end Formal_Model; + use Formal_Model; + + function Is_Sorted (Container : List) return Boolean with + Global => null, + Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); + + procedure Sort (Container : in out List) with + Global => null, + Post => + Length (Container) = Length (Container)'Old + and M_Elements_Sorted (Model (Container)) + and M_Elements_Included + (Left => Model (Container)'Old, + L_Lst => Length (Container), + Right => Model (Container), + R_Lst => Length (Container)) + and M_Elements_Included + (Left => Model (Container), + L_Lst => Length (Container), + Right => Model (Container)'Old, + R_Lst => Length (Container)); + + procedure Merge (Target : in out List; Source : in out List) with + -- Target and Source should not be aliased + Global => null, + Pre => Length (Target) <= Count_Type'Last - Length (Source), + Post => + Length (Target) = Length (Target)'Old + Length (Source)'Old + and Length (Source) = 0 + and (if M_Elements_Sorted (Model (Target)'Old) + and M_Elements_Sorted (Model (Source)'Old) + then + M_Elements_Sorted (Model (Target))) + and M_Elements_Included + (Left => Model (Target)'Old, + L_Lst => Length (Target)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_In_Union + (Model (Target), + Model (Source)'Old, + Model (Target)'Old); + end Generic_Sorting; + +private + pragma SPARK_Mode (Off); + + use Ada.Finalization; + + type Element_Access is access all Element_Type; + + type Node_Type is record + Prev : Count_Type'Base := -1; + Next : Count_Type := 0; + Element : Element_Access := null; + end record; + + type Node_Access is access all Node_Type; + + function "=" (L, R : Node_Type) return Boolean is abstract; + + type Node_Array is array (Count_Type range <>) of Node_Type; + function "=" (L, R : Node_Array) return Boolean is abstract; + + type Node_Array_Access is access all Node_Array; + + type List is new Controlled with record + Free : Count_Type'Base := -1; + Length : Count_Type := 0; + First : Count_Type := 0; + Last : Count_Type := 0; + Nodes : Node_Array_Access := null; + end record; + + overriding procedure Finalize (Container : in out List); + overriding procedure Adjust (Container : in out List); +end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfinse.ads b/gcc/ada/libgnat/a-cfinse.ads index cff2900..d7fdb04 100644 --- a/gcc/ada/libgnat/a-cfinse.ads +++ b/gcc/ada/libgnat/a-cfinse.ads @@ -38,7 +38,10 @@ generic type Element_Type (<>) is private; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Functional_Infinite_Sequences with SPARK_Mode is +package Ada.Containers.Functional_Infinite_Sequences with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is type Sequence is private with Default_Initial_Condition => Length (Sequence) = 0, diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads index b5fa29b..f44e45b 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -53,8 +53,10 @@ generic -- grow via heap allocation. package Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => On + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads index 1e3c57b..7be2eec 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -61,8 +61,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads index f6a033f..ff96d8e 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -59,8 +59,10 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads index e98cda3..dc1a629 100644 --- a/gcc/ada/libgnat/a-chahan.ads +++ b/gcc/ada/libgnat/a-chahan.ads @@ -46,6 +46,8 @@ is pragma Pure; -- In accordance with Ada 2005 AI-362 + pragma Annotate (GNATprove, Always_Return, Handling); + ---------------------------------------- -- Character Classification Functions -- ---------------------------------------- diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads index 35ca010..cc0c70c 100644 --- a/gcc/ada/libgnat/a-cidlli.ads +++ b/gcc/ada/libgnat/a-cidlli.ads @@ -368,10 +368,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads index 8a5f180..142c94e 100644 --- a/gcc/ada/libgnat/a-cihama.ads +++ b/gcc/ada/libgnat/a-cihama.ads @@ -440,10 +440,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads index 2bb4527..f0b0f15 100644 --- a/gcc/ada/libgnat/a-cihase.ads +++ b/gcc/ada/libgnat/a-cihase.ads @@ -589,10 +589,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads index 2bb1208..8a39a5b 100644 --- a/gcc/ada/libgnat/a-cimutr.ads +++ b/gcc/ada/libgnat/a-cimutr.ads @@ -439,10 +439,7 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads index e4fd90d..c240dcc 100644 --- a/gcc/ada/libgnat/a-ciorma.ads +++ b/gcc/ada/libgnat/a-ciorma.ads @@ -355,10 +355,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads index 51545d6..e40ebfa 100644 --- a/gcc/ada/libgnat/a-ciorse.ads +++ b/gcc/ada/libgnat/a-ciorse.ads @@ -454,10 +454,10 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads index 8e0f80f..6f4b118 100644 --- a/gcc/ada/libgnat/a-cobove.ads +++ b/gcc/ada/libgnat/a-cobove.ads @@ -511,10 +511,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index cba10a6..6413375 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -45,6 +45,8 @@ generic package Ada.Containers.Formal_Vectors with SPARK_Mode is + pragma Annotate (GNATprove, Always_Return, Formal_Vectors); + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads index d01c4b4..f863cdc 100644 --- a/gcc/ada/libgnat/a-cofuma.ads +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -49,7 +49,10 @@ generic -- of equivalence over keys is needed, that is, Equivalent_Keys defines a -- key uniquely. -package Ada.Containers.Functional_Maps with SPARK_Mode is +package Ada.Containers.Functional_Maps with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is type Map is private with Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0, diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads index 29f1e9f..ce52f61 100644 --- a/gcc/ada/libgnat/a-cofuse.ads +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -47,7 +47,10 @@ generic -- of equivalence over elements is needed, that is, Equivalent_Elements -- defines an element uniquely. -package Ada.Containers.Functional_Sets with SPARK_Mode is +package Ada.Containers.Functional_Sets with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is type Set is private with Default_Initial_Condition => Is_Empty (Set), diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads index f926a96..8622221 100644 --- a/gcc/ada/libgnat/a-cofuve.ads +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -40,7 +40,10 @@ generic type Element_Type (<>) is private; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Functional_Vectors with SPARK_Mode is +package Ada.Containers.Functional_Vectors with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is subtype Extended_Index is Index_Type'Base range Index_Type'Pred (Index_Type'First) .. Index_Type'Last; diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads index 96ac164..65949dc 100644 --- a/gcc/ada/libgnat/a-cohama.ads +++ b/gcc/ada/libgnat/a-cohama.ads @@ -543,10 +543,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads index fb7dcca..bd82092 100644 --- a/gcc/ada/libgnat/a-cohase.ads +++ b/gcc/ada/libgnat/a-cohase.ads @@ -623,10 +623,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads index 840ef5a..a3bc206 100644 --- a/gcc/ada/libgnat/a-coinve.ads +++ b/gcc/ada/libgnat/a-coinve.ads @@ -512,10 +512,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads index 9b04a4b..7094452 100644 --- a/gcc/ada/libgnat/a-comutr.ads +++ b/gcc/ada/libgnat/a-comutr.ads @@ -491,10 +491,7 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads index c024ce5..1005985 100644 --- a/gcc/ada/libgnat/a-convec.ads +++ b/gcc/ada/libgnat/a-convec.ads @@ -829,10 +829,13 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- Three operations are used to optimize the expansion of "for ... of" + -- loops: the Next(Cursor) (or Previous) procedure in the visible part, + -- and the following Pseudo_Reference and Get_Element_Access functions. + -- See Exp_Ch5 for details, including the leading underscores here. + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads index 7922e7b..1948e2a 100644 --- a/gcc/ada/libgnat/a-coorma.ads +++ b/gcc/ada/libgnat/a-coorma.ads @@ -357,10 +357,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 7596ed6..8888a8c 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -437,10 +437,10 @@ private for Constant_Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads index 1ba10da..ffb96d4 100644 --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -21,6 +21,8 @@ private with System; package Ada.Numerics.Big_Numbers.Big_Integers with Preelaborate is + pragma Annotate (GNATprove, Always_Return, Big_Integers); + type Big_Integer is private with Integer_Literal => From_Universal_Image, Put_Image => Put_Image; diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads index 4118d2b..350d049 100644 --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -20,6 +20,8 @@ with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers; package Ada.Numerics.Big_Numbers.Big_Reals with Preelaborate is + pragma Annotate (GNATprove, Always_Return, Big_Reals); + type Big_Real is private with Real_Literal => From_Universal_Image, Put_Image => Put_Image; diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads index c8a31bb..75783ef 100644 --- a/gcc/ada/libgnat/a-ngelfu.ads +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -40,6 +40,7 @@ package Ada.Numerics.Generic_Elementary_Functions with SPARK_Mode => On is pragma Pure; + pragma Annotate (GNATprove, Always_Return, Generic_Elementary_Functions); -- Preconditions in this unit are meant for analysis only, not for run-time -- checking, so that the expected exceptions are raised when calling diff --git a/gcc/ada/libgnat/a-nlelfu.ads b/gcc/ada/libgnat/a-nlelfu.ads index 10b33e9..b3afd1f 100644 --- a/gcc/ada/libgnat/a-nlelfu.ads +++ b/gcc/ada/libgnat/a-nlelfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Float); pragma Pure (Long_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllefu.ads b/gcc/ada/libgnat/a-nllefu.ads index 7089fc3..e137c67 100644 --- a/gcc/ada/libgnat/a-nllefu.ads +++ b/gcc/ada/libgnat/a-nllefu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Long_Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); pragma Pure (Long_Long_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Long_Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nselfu.ads b/gcc/ada/libgnat/a-nselfu.ads index 10b04ac..6797efd 100644 --- a/gcc/ada/libgnat/a-nselfu.ads +++ b/gcc/ada/libgnat/a-nselfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Short_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Short_Float); pragma Pure (Short_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Short_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nuelfu.ads b/gcc/ada/libgnat/a-nuelfu.ads index 149939b..d4fe745 100644 --- a/gcc/ada/libgnat/a-nuelfu.ads +++ b/gcc/ada/libgnat/a-nuelfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Float); pragma Pure (Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Elementary_Functions); diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads index 839760a..678c345 100644 --- a/gcc/ada/libgnat/a-strbou.ads +++ b/gcc/ada/libgnat/a-strbou.ads @@ -49,6 +49,7 @@ with Ada.Strings.Search; package Ada.Strings.Bounded with SPARK_Mode is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Bounded); generic Max : Positive; @@ -68,6 +69,7 @@ package Ada.Strings.Bounded with SPARK_Mode is Post => Ignore, Contract_Cases => Ignore, Ghost => Ignore); + pragma Annotate (GNATprove, Always_Return, Generic_Bounded_Length); Max_Length : constant Positive := Max; diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index 0d6c5d0..dee64ab 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -63,7 +63,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- The Move procedure copies characters from Source to Target. If Source -- has the same length as Target, then the effect is to assign Source to -- Target. If Source is shorter than Target then: @@ -168,7 +169,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); function Index @@ -231,7 +233,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); -- Each Index function searches, starting from From, for a slice of @@ -300,7 +303,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Index (Source : String; @@ -355,7 +359,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If Going = Forward, returns: -- @@ -408,7 +413,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index'Result) = (Going = Forward) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Index (Source : String; @@ -464,7 +470,8 @@ package Ada.Strings.Fixed with SPARK_Mode is or else (J > From) = (Going = Forward)) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); -- Index searches for the first or last occurrence of any of a set of -- characters (when Test=Inside), or any of the complement of a set of @@ -524,7 +531,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J = From or else (J > From) = (Going = Forward)) then Source (J) = ' '))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index_Non_Blank); -- Returns Index (Source, Maps.To_Set(Space), From, Outside, Going) @@ -562,7 +570,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index_Non_Blank'Result) = (Going = Forward) then Source (J) = ' '))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns Index (Source, Maps.To_Set(Space), Outside, Going) function Count @@ -570,16 +579,18 @@ package Ada.Strings.Fixed with SPARK_Mode is Pattern : String; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => Pattern'Length /= 0, - Global => null; + Pre => Pattern'Length /= 0, + Global => null, + Annotate => (GNATprove, Always_Return); function Count (Source : String; Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0 and then Mapping /= null, - Global => null; + Pre => Pattern'Length /= 0 and then Mapping /= null, + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the maximum number of nonoverlapping slices of Source that match -- Pattern with respect to Mapping. If Pattern is the null string then @@ -589,7 +600,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Set : Maps.Character_Set) return Natural with - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the number of occurrences in Source of characters that are in -- Set. @@ -647,7 +659,8 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_2012 (Find_Token); -- If Source is not the null string and From is not in Source'Range, then -- Index_Error is raised. Otherwise, First is set to the index of the first @@ -709,7 +722,8 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Equivalent to Find_Token (Source, Set, Source'First, Test, First, Last) ------------------------------------ @@ -738,7 +752,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Mapping (Source (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Translate (Source : String; @@ -761,7 +776,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Ada.Strings.Maps.Value (Mapping, Source (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string S whose length is Source'Length and such that S (I) -- is the character to which Mapping maps the corresponding element of @@ -771,27 +787,29 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Mapping : Maps.Character_Mapping_Function) with - Pre => Mapping /= null, - Post => + Pre => Mapping /= null, + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Mapping (Source'Old (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); procedure Translate (Source : in out String; Mapping : Maps.Character_Mapping) with - Post => + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Ada.Strings.Maps.Value (Mapping, Source'Old (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Equivalent to Source := Translate(Source, Mapping) @@ -884,7 +902,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Low - Source'First + By'Length + 1 .. Replace_Slice'Result'Last) = Source (Low .. Source'Last))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If Low > Source'Last + 1, or High < Source'First - 1, then Index_Error -- is propagated. Otherwise: -- @@ -904,7 +923,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => + Pre => Low - 1 <= Source'Last and then High >= Source'First - 1 and then (if High >= Low @@ -916,7 +935,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Replace_Slice (Source, Low, High, By), @@ -962,7 +982,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Before - Source'First + New_Item'Length + 1 .. Insert'Result'Last) = Source (Before .. Source'Last)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Propagates Index_Error if Before is not in -- Source'First .. Source'Last + 1; otherwise, returns -- Source (Source'First .. Before - 1) @@ -974,13 +995,14 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => Before - 1 in Source'First - 1 .. Source'Last and then Source'Length <= Natural'Last - New_Item'Length, -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to Move (Insert (Source, Before, New_Item), Source, Drop) function Overwrite @@ -988,13 +1010,13 @@ package Ada.Strings.Fixed with SPARK_Mode is Position : Positive; New_Item : String) return String with - Pre => + Pre => Position - 1 in Source'First - 1 .. Source'Last and then (if Position - Source'First >= Source'Length - New_Item'Length then Position - Source'First <= Natural'Last - New_Item'Length), - Post => + Post => -- Lower bound of the returned string is 1 @@ -1029,7 +1051,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Position - Source'First + New_Item'Length + 1 .. Overwrite'Result'Last) = Source (Position + New_Item'Length .. Source'Last)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Propagates Index_Error if Position is not in -- Source'First .. Source'Last + 1; otherwise, returns the string obtained -- from Source by consecutively replacing characters starting at Position @@ -1043,7 +1066,7 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Right) with - Pre => + Pre => Position - 1 in Source'First - 1 .. Source'Last and then (if Position - Source'First >= Source'Length - New_Item'Length @@ -1051,7 +1074,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to Move(Overwrite(Source, Position, New_Item), Source, Drop) function Delete @@ -1099,7 +1123,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Delete'Result'Length = Source'Length and then Delete'Result = Source), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If From <= Through, the returned string is -- Replace_Slice(Source, From, Through, ""); otherwise, it is Source with -- lower bound 1. @@ -1111,13 +1136,14 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => (if From <= Through - then (From in Source'Range - and then Through <= Source'Last)), + Pre => (if From <= Through + then (From in Source'Range + and then Through <= Source'Last)), -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Delete (Source, From, Through), @@ -1131,7 +1157,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Side : Trim_End) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1156,7 +1182,8 @@ package Ada.Strings.Fixed with SPARK_Mode is else Index_Non_Blank (Source, Backward)); begin Trim'Result = Source (Low .. High))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string obtained by removing from Source all leading Space -- characters (if Side = Left), all trailing Space characters (if -- Side = Right), or all leading and trailing Space characters (if @@ -1171,7 +1198,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Trim (Source, Side), Source, Justify=>Justify, Pad=>Pad). @@ -1208,7 +1236,8 @@ package Ada.Strings.Fixed with SPARK_Mode is Index (Source, Right, Outside, Backward); begin Trim'Result = Source (Low .. High))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string obtained by removing from Source all leading -- characters in Left and all trailing characters in Right. @@ -1222,7 +1251,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Trim (Source, Left, Right), @@ -1259,7 +1289,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Head'Result (Source'Length + 1 .. Count) = [1 .. Count - Source'Length => Pad]), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the first Count characters of Source. Otherwise, its contents -- are Source concatenated with Count - Source'Length Pad characters. @@ -1273,7 +1304,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Head (Source, Count, Pad), @@ -1322,7 +1354,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Tail'Result (Count - Source'Length + 1 .. Tail'Result'Last) = Source)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the last Count characters of Source. Otherwise, its contents -- are Count-Source'Length Pad characters concatenated with Source. @@ -1336,7 +1369,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Tail (Source, Count, Pad), @@ -1350,7 +1384,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Left : Natural; Right : Character) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1363,7 +1397,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- All characters of the returned string are Right and then (for all C of "*"'Result => C = Right), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function "*" (Left : Natural; @@ -1386,7 +1421,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (for all K in "*"'Result'Range => "*"'Result (K) = Right (Right'First + (K - 1) mod Right'Length)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- These functions replicate a character or string a specified number of -- times. The first function returns a string whose length is Left and each diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads index 476f772..1f22883 100644 --- a/gcc/ada/libgnat/a-strmap.ads +++ b/gcc/ada/libgnat/a-strmap.ads @@ -54,6 +54,8 @@ is pragma Pure; -- In accordance with Ada 2005 AI-362 + pragma Annotate (GNATprove, Always_Return, Maps); + -------------------------------- -- Character Set Declarations -- -------------------------------- diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads index 157c6f3..22a0492 100644 --- a/gcc/ada/libgnat/a-strsea.ads +++ b/gcc/ada/libgnat/a-strsea.ads @@ -52,6 +52,7 @@ with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; package Ada.Strings.Search with SPARK_Mode is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Search); -- The ghost function Match tells whether the slice of Source starting at -- From and of length Pattern'Length matches with Pattern with respect to diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 37c9466..6997594 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -57,6 +57,7 @@ package Ada.Strings.Unbounded with Initial_Condition => Length (Null_Unbounded_String) = 0 is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index 8d00d0b..e5be454 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -86,6 +86,7 @@ package Ada.Strings.Unbounded with Initial_Condition => Length (Null_Unbounded_String) = 0 is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index 7c2ec10..447023d 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -101,14 +101,15 @@ is Name : String := ""; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Open (File : in out File_Type; @@ -116,54 +117,63 @@ is Name : String; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Close (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Delete (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Reset (File : in out File_Type; Mode : File_Mode) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Reset (File : in out File_Type) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and Mode (File)'Old = Mode (File) and (if Mode (File) /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Mode (File : File_Type) return File_Mode with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Name (File : File_Type) return String with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Form (File : File_Type) return String with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Is_Open (File : File_Type) return Boolean with - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); ------------------------------------------------------ -- Control of default input, output and error files -- @@ -199,120 +209,142 @@ is -- an oversight, and was intended to be IN, see AI95-00057. procedure Flush (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Flush with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File) = To and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line_Length (To : Count) with - Post => + Post => Line_Length = To and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Page_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Page_Length (File) = To and Line_Length (File)'Old = Line_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Page_Length (To : Count) with - Post => + Post => Page_Length = To and Line_Length'Old = Line_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Line_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); function Line_Length return Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); function Page_Length return Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Skip_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function End_Of_Line (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_Line return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Skip_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Skip_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function End_Of_Page (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_Page return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_File (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_File return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Set_Col (File : File_Type; To : Positive_Count) with Pre => @@ -325,13 +357,15 @@ is Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Col (To : Positive_Count) with - Pre => Line_Length = 0 or To <= Line_Length, - Post => + Pre => Line_Length = 0 or To <= Line_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line (File : File_Type; To : Positive_Count) with Pre => @@ -344,149 +378,173 @@ is Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line (To : Positive_Count) with - Pre => Page_Length = 0 or To <= Page_Length, - Post => + Pre => Page_Length = 0 or To <= Page_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Col (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Col return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Line (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Line return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); ---------------------------- -- Character Input-Output -- ---------------------------- procedure Get (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Character) with Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; Item : Character) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put (Item : Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Look_Ahead (File : File_Type; Item : out Character; End_Of_Line : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Look_Ahead (Item : out Character; End_Of_Line : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Get_Immediate (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (Item : out Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (File : File_Type; Item : out Character; Available : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (Item : out Character; Available : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); ------------------------- -- String Input-Output -- ------------------------- procedure Get (File : File_Type; Item : out String) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Get_Line (File : File_Type; Item : out String; Last : out Natural) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last + Pre => Is_Open (File) and then Mode (File) = In_File, + Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last else Last = Item'First - 1), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Line (Item : out String; Last : out Natural) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length and (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last else Last = Item'First - 1), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Get_Line (File : File_Type) return String with SPARK_Mode => Off; pragma Ada_05 (Get_Line); @@ -498,19 +556,21 @@ is (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put_Line (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); --------------------------------------- -- Generic packages for Input-Output -- diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads index c5be496..4a2536d 100644 --- a/gcc/ada/libgnat/a-tideio.ads +++ b/gcc/ada/libgnat/a-tideio.ads @@ -54,17 +54,19 @@ package Ada.Text_IO.Decimal_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -73,11 +75,12 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -85,17 +88,19 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -103,7 +108,8 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads index fb80abd..aac90f7 100644 --- a/gcc/ada/libgnat/a-tienio.ads +++ b/gcc/ada/libgnat/a-tienio.ads @@ -29,13 +29,15 @@ package Ada.Text_IO.Enumeration_IO is Default_Setting : Type_Set := Upper_Case; procedure Get (File : File_Type; Item : out Enum) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Enum) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -43,34 +45,38 @@ package Ada.Text_IO.Enumeration_IO is Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Enum; Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Enum; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Enum; Set : Type_Set := Default_Setting) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads index 8a3886d..bbf8e90 100644 --- a/gcc/ada/libgnat/a-tifiio.ads +++ b/gcc/ada/libgnat/a-tifiio.ads @@ -34,17 +34,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -53,11 +55,12 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -65,17 +68,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -83,7 +88,8 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads index 2760b0f..032c6b2 100644 --- a/gcc/ada/libgnat/a-tiflio.ads +++ b/gcc/ada/libgnat/a-tiflio.ads @@ -54,17 +54,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -73,11 +75,12 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -85,17 +88,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -103,7 +108,8 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads index 77efd46..491bc2f 100644 --- a/gcc/ada/libgnat/a-tiinio.ads +++ b/gcc/ada/libgnat/a-tiinio.ads @@ -53,17 +53,19 @@ package Ada.Text_IO.Integer_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -71,35 +73,39 @@ package Ada.Text_IO.Integer_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads index 8c28a0a..67ff7c6 100644 --- a/gcc/ada/libgnat/a-timoio.ads +++ b/gcc/ada/libgnat/a-timoio.ads @@ -53,17 +53,19 @@ package Ada.Text_IO.Modular_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -71,35 +73,39 @@ package Ada.Text_IO.Modular_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-ztenau.adb b/gcc/ada/libgnat/a-ztenau.adb index b03ad8f..d66e547 100644 --- a/gcc/ada/libgnat/a-ztenau.adb +++ b/gcc/ada/libgnat/a-ztenau.adb @@ -306,8 +306,6 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is and then not Is_Letter (To_Character (WC)) and then - not Is_Letter (To_Character (WC)) - and then (WC /= '_' or else From (Stop - 1) = '_'); Stop := Stop + 1; diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb index e70b85b..f5a3df9 100644 --- a/gcc/ada/libgnat/g-socthi.adb +++ b/gcc/ada/libgnat/g-socthi.adb @@ -187,7 +187,9 @@ package body GNAT.Sockets.Thin is return Res; end if; - declare + pragma Warnings (Off, "unreachable code"); + declare -- unreachable if Thread_Blocking_IO is statically True + pragma Warnings (On, "unreachable code"); WSet : aliased Fd_Set; Now : aliased Timeval; diff --git a/gcc/ada/libgnat/g-socthi__vxworks.adb b/gcc/ada/libgnat/g-socthi__vxworks.adb index aeae52d..32973b4 100644 --- a/gcc/ada/libgnat/g-socthi__vxworks.adb +++ b/gcc/ada/libgnat/g-socthi__vxworks.adb @@ -190,7 +190,9 @@ package body GNAT.Sockets.Thin is return Res; end if; - declare + pragma Warnings (Off, "unreachable code"); + declare -- unreachable if Thread_Blocking_IO is statically True + pragma Warnings (On, "unreachable code"); WSet : aliased Fd_Set; Now : aliased Timeval; begin diff --git a/gcc/ada/libgnat/g-spipat.adb b/gcc/ada/libgnat/g-spipat.adb index 6ecbd1b..9fb55bc 100644 --- a/gcc/ada/libgnat/g-spipat.adb +++ b/gcc/ada/libgnat/g-spipat.adb @@ -3961,7 +3961,7 @@ package body GNAT.Spitbol.Patterns is -- Any (one character case) - when PC_Any_CH => + when PC_Any_CH | PC_Char => if Cursor < Length and then Subject (Cursor + 1) = Node.Char then @@ -4103,9 +4103,10 @@ package body GNAT.Spitbol.Patterns is Pop_Region; goto Succeed; - -- Assign on match. This node sets up for the eventual assignment + -- Write/assign on match. This node sets up for the eventual write + -- or assignment. - when PC_Assign_OnM => + when PC_Assign_OnM | PC_Write_OnM => Stack (Stack_Base - 1).Node := Node; Push (CP_Assign'Access); Pop_Region; @@ -4144,9 +4145,9 @@ package body GNAT.Spitbol.Patterns is Push (Node); goto Succeed; - -- Break (one character case) + -- Break & BreakX (one character case) - when PC_Break_CH => + when PC_Break_CH | PC_BreakX_CH => while Cursor < Length loop if Subject (Cursor + 1) = Node.Char then goto Succeed; @@ -4157,9 +4158,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; - -- Break (character set case) + -- Break & BreakX (character set case) - when PC_Break_CS => + when PC_Break_CS | PC_BreakX_CS => while Cursor < Length loop if Is_In (Subject (Cursor + 1), Node.CS) then goto Succeed; @@ -4170,9 +4171,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; - -- Break (string function case) + -- Break & BreakX (string function case) - when PC_Break_VF => declare + when PC_Break_VF | PC_BreakX_VF => declare U : constant VString := Node.VF.all; S : Big_String_Access; L : Natural; @@ -4191,77 +4192,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; end; - -- Break (string pointer case) + -- Break & BreakX (string pointer case) - when PC_Break_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (one character case) - - when PC_BreakX_CH => - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (character set case) - - when PC_BreakX_CS => - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (string function case) - - when PC_BreakX_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (string pointer case) - - when PC_BreakX_VP => declare + when PC_Break_VP | PC_BreakX_VP => declare U : constant VString := Node.VP.all; S : Big_String_Access; L : Natural; @@ -4288,18 +4221,6 @@ package body GNAT.Spitbol.Patterns is Cursor := Cursor + 1; goto Succeed; - -- Character (one character string) - - when PC_Char => - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - -- End of Pattern when PC_EOP => @@ -4941,15 +4862,6 @@ package body GNAT.Spitbol.Patterns is Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); Pop_Region; goto Succeed; - - -- Write on match. This node sets up for the eventual write - - when PC_Write_OnM => - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; end case; -- We are NOT allowed to fall though this case statement, since every @@ -5445,20 +5357,10 @@ package body GNAT.Spitbol.Patterns is goto Fail; end if; - -- Arbno_S (simple Arbno initialize). This is the node that - -- initiates the match of a simple Arbno structure. - - when PC_Arbno_S => - Dout (Img (Node) & - "setting up Arbno alternative " & Img (Node.Alt)); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_X (Arbno initialize). This is the node that initiates - -- the match of a complex Arbno structure. + -- Arbno_S/X (simple and complex Arbno initialize). This is the node + -- that initiates the match of a simple or complex Arbno structure. - when PC_Arbno_X => + when PC_Arbno_S | PC_Arbno_X => Dout (Img (Node) & "setting up Arbno alternative " & Img (Node.Alt)); Push (Node.Alt); diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index 2023b75..7013902 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -29,6 +29,8 @@ with System.Parameters; package Interfaces.C with SPARK_Mode, Pure is + pragma Annotate (GNATprove, Always_Return, C); + -- Each of the types declared in Interfaces.C is C-compatible. -- The types int, short, long, unsigned, ptrdiff_t, size_t, double, diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads index b12ced8..b269869 100644 --- a/gcc/ada/libgnat/interfac.ads +++ b/gcc/ada/libgnat/interfac.ads @@ -38,6 +38,7 @@ package Interfaces is pragma No_Elaboration_Code_All; pragma Pure; + pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/interfac__2020.ads b/gcc/ada/libgnat/interfac__2020.ads index 579e8b4..becd180 100644 --- a/gcc/ada/libgnat/interfac__2020.ads +++ b/gcc/ada/libgnat/interfac__2020.ads @@ -38,6 +38,7 @@ package Interfaces is pragma No_Elaboration_Code_All; pragma Pure; + pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index 880a899..b40e4c3 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -438,6 +438,12 @@ is Ghost, Post => X * (Y + Z) = X * Y + X * Z; + procedure Lemma_Mult_Div (A, B : Big_Integer) + with + Ghost, + Pre => B /= 0, + Post => A * B / B = A; + procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) with Ghost, @@ -469,6 +475,12 @@ is Post => not In_Double_Int_Range (Big_2xxDouble) and then not In_Double_Int_Range (-Big_2xxDouble); + procedure Lemma_Powers (A : Big_Natural; B, C : Natural) + with + Ghost, + Pre => B <= Natural'Last - C, + Post => A**B * A**C = A**(B + C); + procedure Lemma_Powers_Of_2 (M, N : Natural) with Ghost, @@ -606,7 +618,6 @@ is is null; procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) is null; - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is null; procedure Lemma_Double_Big_2xxSingle is null; procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) is null; procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) is null; @@ -629,6 +640,7 @@ is procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; procedure Lemma_Not_In_Range_Big2xx64 is null; + procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; procedure Lemma_Rem_Commutation (X, Y : Double_Uns) is null; procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) is null; procedure Lemma_Rem_Sign (X, Y : Big_Integer) is null; @@ -864,6 +876,23 @@ is Post => abs Big_Q = Big (Qu); -- Proves correctness of the rounding of the unsigned quotient + procedure Prove_Sign_Quotient + with + Ghost, + Pre => Mult /= 0 + and then Quot = Big (X) / (Big (Y) * Big (Z)) + and then Big_R = Big (X) rem (Big (Y) * Big (Z)) + and then Big_Q = + (if Round then + Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) + else Quot), + Post => + (if X >= 0 then + (if Den_Pos then Big_Q >= 0 else Big_Q <= 0) + else + (if Den_Pos then Big_Q <= 0 else Big_Q >= 0)); + -- Proves the correct sign of the signed quotient Big_Q + procedure Prove_Signs with Ghost, @@ -880,7 +909,13 @@ is and then Q = (if (X >= 0) = Den_Pos then To_Int (Qu) else To_Int (-Qu)) and then not (X = Double_Int'First and then Big (Y) * Big (Z) = -1), - Post => Big (R) = Big_R and then Big (Q) = Big_Q; + Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) + and then + (if Round then + Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), + Big (X) / (Big (Y) * Big (Z)), + Big (R)) + else Big (Q) = Big (X) / (Big (Y) * Big (Z))); -- Proves final signs match the intended result after the unsigned -- division is done. @@ -891,6 +926,7 @@ is procedure Prove_Overflow_Case is null; procedure Prove_Quotient_Zero is null; procedure Prove_Round_To_One is null; + procedure Prove_Sign_Quotient is null; ------------------------- -- Prove_Rounding_Case -- @@ -1056,6 +1092,8 @@ is pragma Assert (Big (Double_Uns (Hi (T2))) >= 1); pragma Assert (Big (Double_Uns (Lo (T2))) >= 0); pragma Assert (Big (Double_Uns (Lo (T1))) >= 0); + pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big (Double_Uns (Lo (T1))) >= 0); pragma Assert (Mult >= Big_2xxDouble * Big (Double_Uns (Hi (T2)))); pragma Assert (Mult >= Big_2xxDouble); if Hi (T2) > 1 then @@ -1064,6 +1102,10 @@ is Mult > Big_2xxDouble); elsif Lo (T2) > 0 then pragma Assert (Big (Double_Uns (Lo (T2))) > 0); + pragma Assert (Big_2xxSingle > 0); + pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) > 0); + pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big (Double_Uns (Lo (T1))) > 0); pragma Assert (if X = Double_Int'First and then Round then Mult > Big_2xxDouble); elsif Lo (T1) > 0 then @@ -1138,6 +1180,7 @@ is end if; pragma Assert (abs Big_Q = Big (Qu)); + Prove_Sign_Quotient; -- Set final signs (RM 4.5.5(27-30)) @@ -1225,6 +1268,18 @@ is pragma Assert ((Hi or Lo) = Hi + Lo); end Lemma_Concat_Definition; + ------------------ + -- Lemma_Div_Eq -- + ------------------ + + procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is + begin + pragma Assert ((A - B) * S = R); + pragma Assert ((A - B) * S / S = R / S); + Lemma_Mult_Div (A - B, S); + pragma Assert (A - B = R / S); + end Lemma_Div_Eq; + ------------------------ -- Lemma_Double_Shift -- ------------------------ @@ -1317,6 +1372,19 @@ is + Big (Double_Uns'(Xlo * Ylo))); end Lemma_Mult_Decomposition; + -------------------- + -- Lemma_Mult_Div -- + -------------------- + + procedure Lemma_Mult_Div (A, B : Big_Integer) is + begin + if B > 0 then + pragma Assert (A * B / B = A); + else + pragma Assert (A * (-B) / (-B) = A); + end if; + end Lemma_Mult_Div; + ------------------- -- Lemma_Neg_Div -- ------------------- @@ -1341,6 +1409,7 @@ is Lemma_Powers_Of_2_Commutation (M); Lemma_Powers_Of_2_Commutation (N); Lemma_Powers_Of_2_Commutation (M + N); + Lemma_Powers (Big (Double_Uns'(2)), M, N); if M + N < Double_Size then pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N @@ -1516,6 +1585,8 @@ is pragma Assert (X < 2**(Double_Size - Shift)); pragma Assert (Big (X) < Big_2xx (Double_Size - Shift)); pragma Assert (Y = 2**Shift * X); + Lemma_Lt_Mult (Big (X), Big_2xx (Double_Size - Shift), Big_2xx (Shift), + Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); pragma Assert (Big_2xx (Shift) * Big (X) < Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); Lemma_Powers_Of_2 (Shift, Double_Size - Shift); @@ -2063,8 +2134,8 @@ is begin Lemma_Shift_Left (D (1) & D (2), Scale); - pragma Assert (By (Big_2xxSingle * Big_2xx (Scale) <= Big_2xxDouble, - Big_2xx (Scale) <= Big_2xxSingle)); + Lemma_Ge_Mult (Big_2xxSingle, Big_2xx (Scale), Big_2xxSingle, + Big_2xxSingle * Big_2xx (Scale)); Lemma_Lt_Mult (Big (Double_Uns (D (3))), Big_2xxSingle, Big_2xx (Scale), Big_2xxDouble); Lemma_Shift_Left (Double_Uns (D (3)), Scale); @@ -2225,10 +2296,23 @@ is pragma Assert (Big (Double_Uns (Hi (T3))) + Big (Double_Uns (Hi (T2))) = Big (Double_Uns (S1))); + Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, + Big (Double_Uns (Hi (T3))), + Big (Double_Uns (Hi (T2)))); pragma Assert (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T3))) = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1))); + pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) + + Big_2xxSingle * Big (Double_Uns (S2)) + + Big (Double_Uns (S3))); + pragma Assert + (By (Big (Double_Uns (Q)) * Big (Zu) = Big3 (S1, S2, S3), + Big3 (S1, S2, S3) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) + + Big_2xxSingle * Big (Double_Uns (S2)) + + Big (Double_Uns (S3)))); end Prove_Multiplication; ----------------------------- @@ -2357,6 +2441,7 @@ is Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo); pragma Assert (Double_Uns (Lo (T1 rem Zlo)) = T1 rem Zlo); Lemma_Hi_Lo (T2, Lo (T1 rem Zlo), D (4)); + pragma Assert (T1 rem Zlo < Double_Uns (Zlo)); pragma Assert (T1 rem Zlo + Double_Uns'(1) <= Double_Uns (Zlo)); Lemma_Ge_Commutation (Double_Uns (Zlo), T1 rem Zlo + Double_Uns'(1)); Lemma_Add_Commutation (T1 rem Zlo, 1); @@ -2365,6 +2450,9 @@ is pragma Assert (Mult = Big (Double_Uns (Zlo)) * (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru)); + pragma Assert (Big_2xxSingle * Big (Double_Uns (D (2))) + + Big (Double_Uns (D (3))) + < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1)); Lemma_Div_Lt (Big (T1), Big_2xxSingle, Big (Double_Uns (Zlo))); Lemma_Div_Commutation (T1, Double_Uns (Zlo)); Lemma_Lo_Is_Ident (T1 / Zlo); diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index 6dac572..c3d9f6a 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -541,8 +541,10 @@ is end if; end if; + pragma Assert (In_Int32_Range (Big_Q)); pragma Assert (Big (Qu) = abs Big_Q); pragma Assert (Big (Ru) = abs Big_R); + Prove_Sign_R; -- Set final signs (RM 4.5.5(27-30)) @@ -563,7 +565,6 @@ is Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - Prove_Sign_R; Prove_Signs; end Scaled_Divide32; diff --git a/gcc/ada/libgnat/s-atacco.ads b/gcc/ada/libgnat/s-atacco.ads index b3559ff..a928d47 100644 --- a/gcc/ada/libgnat/s-atacco.ads +++ b/gcc/ada/libgnat/s-atacco.ads @@ -55,9 +55,11 @@ package System.Address_To_Access_Conversions is -- of no strict aliasing. function To_Pointer (Value : Address) return Object_Pointer with - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function To_Address (Value : Object_Pointer) return Address with - SPARK_Mode => Off; + SPARK_Mode => Off, + Annotate => (GNATprove, Always_Return); pragma Import (Intrinsic, To_Pointer); pragma Import (Intrinsic, To_Address); diff --git a/gcc/ada/libgnat/s-conca2.adb b/gcc/ada/libgnat/s-conca2.adb index 49982f5..2a263ca 100644 --- a/gcc/ada/libgnat/s-conca2.adb +++ b/gcc/ada/libgnat/s-conca2.adb @@ -46,26 +46,8 @@ package body System.Concat_2 is R (F .. L) := S1; F := L + 1; - L := R'Last; + L := F + S2'Length - 1; R (F .. L) := S2; end Str_Concat_2; - ------------------------- - -- Str_Concat_Bounds_2 -- - ------------------------- - - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String) - is - begin - if S1 = "" then - Lo := S2'First; - Hi := S2'Last; - else - Lo := S1'First; - Hi := S1'Last + S2'Length; - end if; - end Str_Concat_Bounds_2; - end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca2.ads b/gcc/ada/libgnat/s-conca2.ads index f9c7393..450435a 100644 --- a/gcc/ada/libgnat/s-conca2.ads +++ b/gcc/ada/libgnat/s-conca2.ads @@ -36,15 +36,8 @@ package System.Concat_2 is procedure Str_Concat_2 (R : out String; S1, S2 : String); -- Performs the operation R := S1 & S2. The bounds of R are known to be - -- correct (usually set by a call to the Str_Concat_Bounds_2 procedure - -- below), so no bounds checks are required, and it is known that none of + -- sufficient so no bound checks are required, and it is known that none of -- the input operands overlaps R. No assumptions can be made about the -- lower bounds of any of the operands. - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the two - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca3.adb b/gcc/ada/libgnat/s-conca3.adb index d607082..ddba832 100644 --- a/gcc/ada/libgnat/s-conca3.adb +++ b/gcc/ada/libgnat/s-conca3.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_2; - package body System.Concat_3 is pragma Suppress (All_Checks); @@ -52,25 +50,8 @@ package body System.Concat_3 is R (F .. L) := S2; F := L + 1; - L := R'Last; + L := F + S3'Length - 1; R (F .. L) := S3; end Str_Concat_3; - ------------------------- - -- Str_Concat_Bounds_3 -- - ------------------------- - - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String) - is - begin - System.Concat_2.Str_Concat_Bounds_2 (Lo, Hi, S2, S3); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_3; - end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca3.ads b/gcc/ada/libgnat/s-conca3.ads index d7282ff..2ff3abc 100644 --- a/gcc/ada/libgnat/s-conca3.ads +++ b/gcc/ada/libgnat/s-conca3.ads @@ -36,15 +36,8 @@ package System.Concat_3 is procedure Str_Concat_3 (R : out String; S1, S2, S3 : String); -- Performs the operation R := S1 & S2 & S3. The bounds of R are known to - -- be correct (usually set by a call to the Str_Concat_Bounds_3 procedure - -- below), so no bounds checks are required, and it is known that none of - -- the input operands overlaps R. No assumptions can be made about the + -- be sufficient so no bound checks are required, and it is known that none + -- of the input operands overlaps R. No assumptions can be made about the -- lower bounds of any of the operands. - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the three - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca4.adb b/gcc/ada/libgnat/s-conca4.adb index 694033a..e1c7e92 100644 --- a/gcc/ada/libgnat/s-conca4.adb +++ b/gcc/ada/libgnat/s-conca4.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_3; - package body System.Concat_4 is pragma Suppress (All_Checks); @@ -56,25 +54,8 @@ package body System.Concat_4 is R (F .. L) := S3; F := L + 1; - L := R'Last; + L := F + S4'Length - 1; R (F .. L) := S4; end Str_Concat_4; - ------------------------- - -- Str_Concat_Bounds_4 -- - ------------------------- - - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String) - is - begin - System.Concat_3.Str_Concat_Bounds_3 (Lo, Hi, S2, S3, S4); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_4; - end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca4.ads b/gcc/ada/libgnat/s-conca4.ads index 88b464d..ecc3108 100644 --- a/gcc/ada/libgnat/s-conca4.ads +++ b/gcc/ada/libgnat/s-conca4.ads @@ -36,15 +36,8 @@ package System.Concat_4 is procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String); -- Performs the operation R := S1 & S2 & S3 & S4. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the four - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca5.adb b/gcc/ada/libgnat/s-conca5.adb index f611260..2283747 100644 --- a/gcc/ada/libgnat/s-conca5.adb +++ b/gcc/ada/libgnat/s-conca5.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_4; - package body System.Concat_5 is pragma Suppress (All_Checks); @@ -60,25 +58,8 @@ package body System.Concat_5 is R (F .. L) := S4; F := L + 1; - L := R'Last; + L := F + S5'Length - 1; R (F .. L) := S5; end Str_Concat_5; - ------------------------- - -- Str_Concat_Bounds_5 -- - ------------------------- - - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String) - is - begin - System.Concat_4.Str_Concat_Bounds_4 (Lo, Hi, S2, S3, S4, S5); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_5; - end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca5.ads b/gcc/ada/libgnat/s-conca5.ads index f6b8988..be7aace 100644 --- a/gcc/ada/libgnat/s-conca5.ads +++ b/gcc/ada/libgnat/s-conca5.ads @@ -36,15 +36,8 @@ package System.Concat_5 is procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the five - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca6.adb b/gcc/ada/libgnat/s-conca6.adb index 66b767f..b574d04 100644 --- a/gcc/ada/libgnat/s-conca6.adb +++ b/gcc/ada/libgnat/s-conca6.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_5; - package body System.Concat_6 is pragma Suppress (All_Checks); @@ -64,25 +62,8 @@ package body System.Concat_6 is R (F .. L) := S5; F := L + 1; - L := R'Last; + L := F + S6'Length - 1; R (F .. L) := S6; end Str_Concat_6; - ------------------------- - -- Str_Concat_Bounds_6 -- - ------------------------- - - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String) - is - begin - System.Concat_5.Str_Concat_Bounds_5 (Lo, Hi, S2, S3, S4, S5, S6); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_6; - end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca6.ads b/gcc/ada/libgnat/s-conca6.ads index e753251..2aac3d0 100644 --- a/gcc/ada/libgnat/s-conca6.ads +++ b/gcc/ada/libgnat/s-conca6.ads @@ -36,15 +36,8 @@ package System.Concat_6 is procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_6 procedure below), so no bounds checks are required, + -- bounds of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the six - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca7.adb b/gcc/ada/libgnat/s-conca7.adb index 0250887..e624b5c 100644 --- a/gcc/ada/libgnat/s-conca7.adb +++ b/gcc/ada/libgnat/s-conca7.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_6; - package body System.Concat_7 is pragma Suppress (All_Checks); @@ -71,25 +69,8 @@ package body System.Concat_7 is R (F .. L) := S6; F := L + 1; - L := R'Last; + L := F + S7'Length - 1; R (F .. L) := S7; end Str_Concat_7; - ------------------------- - -- Str_Concat_Bounds_7 -- - ------------------------- - - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String) - is - begin - System.Concat_6.Str_Concat_Bounds_6 (Lo, Hi, S2, S3, S4, S5, S6, S7); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_7; - end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca7.ads b/gcc/ada/libgnat/s-conca7.ads index c130ddf..7554995 100644 --- a/gcc/ada/libgnat/s-conca7.ads +++ b/gcc/ada/libgnat/s-conca7.ads @@ -38,15 +38,8 @@ package System.Concat_7 is (R : out String; S1, S2, S3, S4, S5, S6, S7 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, + -- bounds of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the seven - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca8.adb b/gcc/ada/libgnat/s-conca8.adb index d6ee36c..98b2e59 100644 --- a/gcc/ada/libgnat/s-conca8.adb +++ b/gcc/ada/libgnat/s-conca8.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_7; - package body System.Concat_8 is pragma Suppress (All_Checks); @@ -75,26 +73,8 @@ package body System.Concat_8 is R (F .. L) := S7; F := L + 1; - L := R'Last; + L := F + S8'Length - 1; R (F .. L) := S8; end Str_Concat_8; - ------------------------- - -- Str_Concat_Bounds_8 -- - ------------------------- - - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String) - is - begin - System.Concat_7.Str_Concat_Bounds_7 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_8; - end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca8.ads b/gcc/ada/libgnat/s-conca8.ads index dda35c1..a249154 100644 --- a/gcc/ada/libgnat/s-conca8.ads +++ b/gcc/ada/libgnat/s-conca8.ads @@ -38,15 +38,8 @@ package System.Concat_8 is (R : out String; S1, S2, S3, S4, S5, S6, S7, S8 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No + -- The bounds of R are known to be sufficient so no bound checks are + -- required and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the eight - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca9.adb b/gcc/ada/libgnat/s-conca9.adb index bfe228e..08860f5 100644 --- a/gcc/ada/libgnat/s-conca9.adb +++ b/gcc/ada/libgnat/s-conca9.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_8; - package body System.Concat_9 is pragma Suppress (All_Checks); @@ -79,26 +77,8 @@ package body System.Concat_9 is R (F .. L) := S8; F := L + 1; - L := R'Last; + L := F + S9'Length - 1; R (F .. L) := S9; end Str_Concat_9; - ------------------------- - -- Str_Concat_Bounds_9 -- - ------------------------- - - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) - is - begin - System.Concat_8.Str_Concat_Bounds_8 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8, S9); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_9; - end System.Concat_9; diff --git a/gcc/ada/libgnat/s-conca9.ads b/gcc/ada/libgnat/s-conca9.ads index 7737a1e..39560ff 100644 --- a/gcc/ada/libgnat/s-conca9.ads +++ b/gcc/ada/libgnat/s-conca9.ads @@ -38,15 +38,8 @@ package System.Concat_9 is (R : out String; S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8 & S9. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_9 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No + -- The bounds of R are known to be sufficient so no bound checks are + -- required, and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the nine - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_9; diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb index 24b7601..359e940 100644 --- a/gcc/ada/libgnat/s-secsta.adb +++ b/gcc/ada/libgnat/s-secsta.adb @@ -506,12 +506,17 @@ package body System.Secondary_Stack is Mem_Size : Memory_Size) return Boolean is begin + -- First check if the chunk is full (Byte is > Memory'Last in that + -- case), then check there is enough free memory. + -- Byte - 1 denotes the last occupied byte. Subtracting that byte from -- the memory capacity of the chunk yields the size of the free memory -- within the chunk. The chunk can fit the request as long as the free -- memory is as big as the request. - return Chunk.Size - (Byte - 1) >= Mem_Size; + return Chunk.Memory'Last >= Byte + and then Chunk.Size - (Byte - 1) >= Mem_Size; + end Has_Enough_Free_Memory; ---------------------- diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads index f4d1a5b..f1f3b79 100644 --- a/gcc/ada/libgnat/s-stchop.ads +++ b/gcc/ada/libgnat/s-stchop.ads @@ -72,7 +72,7 @@ package System.Stack_Checking.Operations is private Cache : aliased Stack_Access := Null_Stack; - pragma Export (C, Cache, "_gnat_stack_cache"); - pragma Export (C, Stack_Check, "_gnat_stack_check"); + pragma Export (C, Cache, "__gnat_stack_cache"); + pragma Export (C, Stack_Check, "__gnat_stack_check"); end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads index 48af71b..d047368 100644 --- a/gcc/ada/libgnat/s-stoele.ads +++ b/gcc/ada/libgnat/s-stoele.ads @@ -43,6 +43,8 @@ package System.Storage_Elements is -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, -- this is Pure in any case (AI-362). + pragma Annotate (GNATprove, Always_Return, Storage_Elements); + -- We also add the pragma Pure_Function to the operations in this package, -- because otherwise functions with parameters derived from Address are -- treated as non-pure by the back-end (see exp_ch6.adb). This is because diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads deleted file mode 100644 index 457e641..0000000 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7.x PPC RTP) -- --- -- --- Copyright (C) 1992-2022, 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 the VxWorks version of this package for RTPs - -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 := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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 := True; - 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 := True; - Stack_Check_Limits : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads deleted file mode 100644 index 7ef6764..0000000 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7 Version x86 for RTPs) -- --- -- --- Copyright (C) 1992-2022, 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 := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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 := True; - 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 := True; - Stack_Check_Limits : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index e7653eb..74c0d17 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -54,6 +54,13 @@ begin Display_Usage_Version_And_Help; + -- Line for -P + + Write_Str (" -Pproj Build GNAT Project File proj using GPRbuild"); + Write_Eol; + Write_Str (" Treats all other switches as GPRbuild switches"); + Write_Eol; + -- Line for -a Write_Str (" -a Consider all files, even readonly ali files"); @@ -169,11 +176,6 @@ begin Write_Str (" -p Create missing obj, lib and exec dirs"); Write_Eol; - -- Line for -P - - Write_Str (" -Pproj Use GNAT Project File proj"); - Write_Eol; - -- Line for -q Write_Str (" -q Be quiet/terse"); diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 158050a..33c668d 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -61,7 +61,8 @@ package body Ch11 is Handled_Stmt_Seq_Node := New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr); Set_Statements - (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq)); + (Handled_Stmt_Seq_Node, + P_Sequence_Of_Statements (SS_Extm_Sreq, Handled => True)); if Token = Tok_Exception then Scan; -- past EXCEPTION diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 557a9cb..82df4cf 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -77,40 +77,33 @@ package body Ch3 is -- are enabled, to remove the ambiguity of "when X in A | B". We consider -- it very unlikely that this will ever arise in practice. - procedure P_Declarative_Items + procedure P_Declarative_Item (Decls : List_Id; Done : out Boolean; Declare_Expression : Boolean; - In_Spec : Boolean); - -- Scans out a single declarative item, or, in the case of a declaration - -- with a list of identifiers, a list of declarations, one for each of the - -- identifiers in the list. The declaration or declarations scanned are - -- appended to the given list. Done indicates whether or not there may be - -- additional declarative items to scan. If Done is True, then a decision - -- has been made that there are no more items to scan. If Done is False, - -- then there may be additional declarations to scan. - -- - -- Declare_Expression is true if we are parsing a declare_expression, in - -- which case we want to suppress certain style checking. - -- - -- In_Spec is true if we are scanning a package declaration, and is used to - -- generate an appropriate message if a statement is encountered in such a - -- context. + In_Spec : Boolean; + In_Statements : Boolean); + -- Parses a single declarative item. The parameters have the same meaning + -- as for P_Declarative_Items. If the declarative item has multiple + -- identifiers, as in "X, Y, Z : ...", then one declaration is appended to + -- Decls for each of the identifiers. procedure P_Identifier_Declarations - (Decls : List_Id; - Done : out Boolean; - In_Spec : Boolean); - -- Scans out a set of declarations for an identifier or list of - -- identifiers, and appends them to the given list. The parameters have - -- the same significance as for P_Declarative_Items. + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean; + In_Statements : Boolean); + -- Parses a sequence of declarations for an identifier or list of + -- identifiers, and appends them to the given list. The parameters + -- have the same meaning as for P_Declarative_Items. procedure Statement_When_Declaration_Expected (Decls : List_Id; Done : out Boolean; In_Spec : Boolean); -- Called when a statement is found at a point where a declaration was - -- expected. The parameters are as described for P_Declarative_Items. + -- expected. The parameters have the same meaning as for + -- P_Declarative_Items. procedure Set_Declaration_Expected; -- Posts a "declaration expected" error messages at the start of the @@ -1307,9 +1300,10 @@ package body Ch3 is -- Error recovery: can raise Error_Resync procedure P_Identifier_Declarations - (Decls : List_Id; - Done : out Boolean; - In_Spec : Boolean) + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean; + In_Statements : Boolean) is Acc_Node : Node_Id; Decl_Node : Node_Id; @@ -1331,6 +1325,13 @@ package body Ch3 is Num_Idents : Nat := 1; -- Number of identifiers stored in Idents + function Identifier_Starts_Statement return Boolean; + -- Called with Token being an identifier that might start a declaration + -- or a statement. True if we are parsing declarations in a sequence of + -- statements, and this identifier is the start of a statement. If this + -- is true, we quit parsing declarations, and return Done = True so the + -- caller will switch to parsing statements. + procedure No_List; -- This procedure is called in renames cases to make sure that we do -- not have more than one identifier. If we do have more than one @@ -1342,6 +1343,55 @@ package body Ch3 is -- returns True, otherwise returns False. Includes checking for some -- common error cases. + --------------------------------- + -- Identifier_Starts_Statement -- + --------------------------------- + + function Identifier_Starts_Statement return Boolean is + pragma Assert (Token = Tok_Identifier); + Scan_State : Saved_Scan_State; + Result : Boolean := False; + begin + if not In_Statements then + return False; + end if; + + Save_Scan_State (Scan_State); + Scan; + + case Token is + when Tok_Comma => -- "X, ..." is a declaration + null; + + when Tok_Colon => + -- "X : ..." is usually a declaration, but "X : begin..." is + -- not. We return true for things like "X : Y : begin...", + -- which is a syntax error, because that gives better error + -- recovery for some ACATS. + + Scan; + + if Token in Token_Class_Labeled_Stmt then + Result := True; + + elsif Token = Tok_Identifier then + Scan; + if Token = Tok_Colon then + Scan; + if Token in Token_Class_Labeled_Stmt then + Result := True; + end if; + end if; + end if; + + when others => + Result := True; + end case; + + Restore_Scan_State (Scan_State); + return Result; + end Identifier_Starts_Statement; + ------------- -- No_List -- ------------- @@ -1395,6 +1445,11 @@ package body Ch3 is -- Start of processing for P_Identifier_Declarations begin + if Identifier_Starts_Statement then + Done := True; + return; + end if; + Ident_Sloc := Token_Ptr; Save_Scan_State (Scan_State); -- at first identifier Idents (1) := P_Defining_Identifier (C_Comma_Colon); @@ -1514,6 +1569,10 @@ package body Ch3 is -- Otherwise we definitely have an ordinary identifier with a junk -- token after it. + elsif In_Statements then + Done := True; + return; + else -- If in -gnatd.2 mode, try for statements @@ -4464,13 +4523,11 @@ package body Ch3 is -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} - -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items + -- Error recovery: cannot raise Error_Resync (because P_Declarative_Item -- handles errors, and returns cleanly after an error has occurred) function P_Declarative_Part return List_Id is - Decls : List_Id; - Done : Boolean; - + Decls : constant List_Id := New_List; begin -- Indicate no bad declarations detected yet. This will be reset by -- P_Declarative_Items if a bad declaration is discovered. @@ -4482,15 +4539,10 @@ package body Ch3 is -- discussion in Par for further details SIS_Entry_Active := False; - Decls := New_List; - -- Loop to scan out the declarations - - loop - P_Declarative_Items - (Decls, Done, Declare_Expression => False, In_Spec => False); - exit when Done; - end loop; + P_Declarative_Items + (Decls, Declare_Expression => False, + In_Spec => False, In_Statements => False); -- Get rid of active SIS entry which is left set only if we scanned a -- procedure declaration and have not found the body. We could give @@ -4514,11 +4566,12 @@ package body Ch3 is -- Error recovery: cannot raise Error_Resync. If an error resync occurs, -- then the scan is set past the next semicolon and Error is returned. - procedure P_Declarative_Items + procedure P_Declarative_Item (Decls : List_Id; Done : out Boolean; Declare_Expression : Boolean; - In_Spec : Boolean) + In_Spec : Boolean; + In_Statements : Boolean) is Scan_State : Saved_Scan_State; @@ -4549,20 +4602,38 @@ package body Ch3 is Save_Scan_State (Scan_State); Scan; -- past FOR - if Token = Tok_Identifier then - Scan; -- past identifier - - if Token = Tok_In then - Restore_Scan_State (Scan_State); - Statement_When_Declaration_Expected (Decls, Done, In_Spec); - return; + declare + Is_Statement : Boolean := True; + begin + if Token = Tok_Identifier then + Scan; -- past identifier + if Token in Tok_Use | Tok_Apostrophe then + Is_Statement := False; + elsif Token = Tok_Dot then + Scan; + if Token = Tok_Identifier then + Scan; + Is_Statement := Token in Tok_In | Tok_Of; + end if; + end if; + else + Is_Statement := False; end if; - end if; - -- Not a loop, so must be rep clause + Restore_Scan_State (Scan_State); - Restore_Scan_State (Scan_State); - Append (P_Representation_Clause, Decls); + if Is_Statement then + if not In_Statements then + Statement_When_Declaration_Expected + (Decls, Done, In_Spec); + end if; + + Done := True; + return; + else + Append (P_Representation_Clause, Decls); + end if; + end; when Tok_Generic => Check_Bad_Layout; @@ -4585,7 +4656,7 @@ package body Ch3 is -- Normal case, no overriding, or overriding followed by colon else - P_Identifier_Declarations (Decls, Done, In_Spec); + P_Identifier_Declarations (Decls, Done, In_Spec, In_Statements); end if; when Tok_Package => @@ -4593,7 +4664,14 @@ package body Ch3 is Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); when Tok_Pragma => - Append (P_Pragma, Decls); + -- If we see a pragma and In_Statements is true, we want to let + -- the statement-parser deal with it. + + if In_Statements then + Done := True; + else + Append (P_Pragma, Decls); + end if; when Tok_Protected => Check_Bad_Layout; @@ -4779,10 +4857,16 @@ package body Ch3 is | Tok_Select | Tok_While => - -- But before we decide that it's a statement, let's check for - -- a reserved word misused as an identifier. + -- If we parsing declarations in a sequence of statements, we want + -- to let the caller continue parsing statements. - if Is_Reserved_Identifier then + if In_Statements then + Done := True; + + -- Otherwise, give an error. But before we decide that it's a + -- statement, check for a reserved word misused as an identifier. + + elsif Is_Reserved_Identifier then Save_Scan_State (Scan_State); Scan; -- past the token @@ -4799,10 +4883,12 @@ package body Ch3 is else Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); - P_Identifier_Declarations (Decls, Done, In_Spec); + P_Identifier_Declarations + (Decls, Done, In_Spec, In_Statements); end if; - -- If not reserved identifier, then it's definitely a statement + -- If not reserved identifier, then it's an incorrectly placed a + -- statement. else Statement_When_Declaration_Expected (Decls, Done, In_Spec); @@ -4810,12 +4896,18 @@ package body Ch3 is end if; -- The token RETURN may well also signal a missing BEGIN situation, - -- however, we never let it end the declarative part, because it may - -- also be part of a half-baked function declaration. + -- however, we never let it end the declarative part, because it + -- might also be part of a half-baked function declaration. If we are + -- In_Statements, then let the caller parse it; otherwise, it's an + -- error. when Tok_Return => - Error_Msg_SC ("misplaced RETURN statement"); - raise Error_Resync; + if In_Statements then + Done := True; + else + Error_Msg_SC ("misplaced RETURN statement"); + raise Error_Resync; + end if; -- PRIVATE definitely terminates the declarations in a spec, -- and is an error in a body. @@ -4838,6 +4930,10 @@ package body Ch3 is -- But first check for misuse of a reserved identifier. when others => + if In_Statements then + Done := True; + return; + end if; -- Here we check for a reserved identifier @@ -4853,7 +4949,8 @@ package body Ch3 is Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); Check_Bad_Layout; - P_Identifier_Declarations (Decls, Done, In_Spec); + P_Identifier_Declarations + (Decls, Done, In_Spec, In_Statements); end if; else @@ -4869,6 +4966,21 @@ package body Ch3 is exception when Error_Resync => Resync_Past_Semicolon; + end P_Declarative_Item; + + procedure P_Declarative_Items + (Decls : List_Id; + Declare_Expression : Boolean; + In_Spec : Boolean; + In_Statements : Boolean) + is + Done : Boolean; + begin + loop + P_Declarative_Item + (Decls, Done, Declare_Expression, In_Spec, In_Statements); + exit when Done; + end loop; end P_Declarative_Items; ---------------------------------- @@ -4888,9 +5000,8 @@ package body Ch3 is (Declare_Expression : Boolean) return List_Id is Decl : Node_Id; - Decls : List_Id; + Decls : constant List_Id := New_List; Kind : Node_Kind; - Done : Boolean; begin -- Indicate no bad declarations detected yet in the current context: @@ -4904,15 +5015,8 @@ package body Ch3 is SIS_Entry_Active := False; - -- Loop to scan out declarations - - Decls := New_List; - - loop - P_Declarative_Items - (Decls, Done, Declare_Expression, In_Spec => True); - exit when Done; - end loop; + P_Declarative_Items + (Decls, Declare_Expression, In_Spec => True, In_Statements => False); -- Get rid of active SIS entry. This is set only if we have scanned a -- procedure declaration and have not found the body. We could give @@ -5007,11 +5111,11 @@ package body Ch3 is ---------------------- procedure Skip_Declaration (S : List_Id) is - Dummy_Done : Boolean; - pragma Warnings (Off, Dummy_Done); + Ignored_Done : Boolean; begin - P_Declarative_Items - (S, Dummy_Done, Declare_Expression => False, In_Spec => False); + P_Declarative_Item + (S, Ignored_Done, Declare_Expression => False, In_Spec => False, + In_Statements => False); end Skip_Declaration; ----------------------------------------- diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 0421bd5..3835588 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -144,8 +144,9 @@ package body Ch5 is -- parsing a statement, then the scan pointer is advanced past the next -- semicolon and the parse continues. - function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is - + function P_Sequence_Of_Statements + (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id + is Statement_Required : Boolean; -- This flag indicates if a subsequent statement (other than a pragma) -- is required. It is initialized from the Sreq flag, and modified as @@ -158,11 +159,6 @@ package body Ch5 is -- sequence cannot contain only labels. This flag is set whenever a -- label is encountered, to enforce this rule at the end of a sequence. - Declaration_Found : Boolean := False; - -- This flag is set True if a declaration is encountered, so that the - -- error message about declarations in the statement part is only - -- given once for a given sequence of statements. - Scan_State_Label : Saved_Scan_State; Scan_State : Saved_Scan_State; @@ -171,28 +167,12 @@ package body Ch5 is Id_Node : Node_Id; Name_Node : Node_Id; - procedure Junk_Declaration; - -- Procedure called to handle error of declaration encountered in - -- statement sequence. + Decl_Loc, Label_Loc : Source_Ptr := No_Location; + -- Sloc of the first declaration/label encountered, if any. procedure Test_Statement_Required; -- Flag error if Statement_Required flag set - ---------------------- - -- Junk_Declaration -- - ---------------------- - - procedure Junk_Declaration is - begin - if (not Declaration_Found) or All_Errors_Mode then - Error_Msg_SC -- CODEFIX - ("declarations must come before BEGIN"); - Declaration_Found := True; - end if; - - Skip_Declaration (Statement_List); - end Junk_Declaration; - ----------------------------- -- Test_Statement_Required -- ----------------------------- @@ -243,9 +223,10 @@ package body Ch5 is Append_To (Statement_List, Null_Stm); end; - -- If not Ada 2012, or not special case above, give error message + -- If not Ada 2012, or not special case above, and no declaration + -- seen (as allowed in Ada 2020), give error message. - else + elsif No (Decl_Loc) then Error_Msg_BC -- CODEFIX ("statement expected"); end if; @@ -259,9 +240,45 @@ package body Ch5 is Statement_Required := SS_Flags.Sreq; Statement_Seen := False; + -- In Ada 2022, we allow declarative items to be mixed with + -- statements. The loop below alternates between calling + -- P_Declarative_Items to parse zero or more declarative items, and + -- parsing a statement. + loop Ignore (Tok_Semicolon); + declare + Num_Statements : constant Nat := List_Length (Statement_List); + begin + P_Declarative_Items + (Statement_List, Declare_Expression => False, + In_Spec => False, In_Statements => True); + + -- Use the length of the list to determine whether we parsed any + -- declarative items. If so, it's an error pre-2022. ???We should + -- be calling Error_Msg_Ada_2022_Feature below, to advertise the + -- new feature, but that causes a lot of test diffs, so for now, + -- we mimic the old "...before begin" message. + + if List_Length (Statement_List) > Num_Statements then + if All_Errors_Mode or else No (Decl_Loc) then + Decl_Loc := Sloc (Pick (Statement_List, Num_Statements + 1)); + + if False then + Error_Msg_Ada_2022_Feature + ("declarations mixed with statements", + Sloc (Pick (Statement_List, Num_Statements + 1))); + else + if Ada_Version < Ada_2022 then + Error_Msg + ("declarations must come before BEGIN", Decl_Loc); + end if; + end if; + end if; + end if; + end; + begin if Style_Check then Style.Check_Indentation; @@ -613,14 +630,6 @@ package body Ch5 is Append_To (Statement_List, P_For_Statement (Id_Node)); - -- Improper statement follows label. If we have an - -- expression token, then assume the colon was part - -- of a misplaced declaration. - - elsif Token not in Token_Class_Eterm then - Restore_Scan_State (Scan_State_Label); - Junk_Declaration; - -- Otherwise complain we have inappropriate statement else @@ -811,6 +820,10 @@ package body Ch5 is Append_To (Statement_List, P_Label); Statement_Required := True; + if No (Label_Loc) then + Label_Loc := Sloc (Last (Statement_List)); + end if; + -- Pragma appearing as a statement in a statement sequence when Tok_Pragma => @@ -941,14 +954,9 @@ package body Ch5 is -- handling of a bad statement. when others => - if Token in Token_Class_Declk then - Junk_Declaration; - - else - Error_Msg_BC -- CODEFIX - ("statement expected"); - raise Error_Resync; - end if; + Error_Msg_BC -- CODEFIX + ("statement expected"); + raise Error_Resync; end case; -- On error resynchronization, skip past next semicolon, and, since @@ -966,7 +974,96 @@ package body Ch5 is exit when SS_Flags.Unco; end loop; - return Statement_List; + -- If there are no declarative items in the list, or if the list is part + -- of a handled sequence of statements, we just return the list. + -- Otherwise, we wrap the list in a block statement, so the declarations + -- will have a proper scope. In the Handled case, it would be wrong to + -- wrap, because we want the code before and after "begin" to be in the + -- same scope. Example: + -- + -- if ... then + -- use Some_Package; + -- Do_Something (...); + -- end if; + -- + -- is tranformed into: + -- + -- if ... then + -- begin + -- use Some_Package; + -- Do_Something (...); + -- end; + -- end if; + -- + -- But we don't wrap this: + -- + -- declare + -- X : Integer; + -- begin + -- X : Integer; + -- + -- Otherwise, we would fail to detect the error (conflicting X's). + -- Similarly, if a representation clause appears in the statement + -- part, we don't want it to appear more nested than the declarative + -- part -- that would cause an unwanted error. + + if Present (Decl_Loc) then + -- Forbid labels and declarative items from coexisting. Otherwise, + -- one could jump past a declaration, leading to chaos. Jumping + -- backward past a declaration is also questionable -- does the + -- declaration get elaborated again? Is secondary stack storage + -- reclaimed? (A more liberal rule was proposed, but this is what + -- we're doing for now.) + + if Present (Label_Loc) then + Error_Msg ("declarative item in same list as label", Decl_Loc); + Error_Msg ("label in same list as declarative item", Label_Loc); + end if; + + -- Forbid exception handlers and declarative items from + -- coexisting. Example: + -- + -- X : Integer := 123; + -- procedure P is + -- begin + -- X : Integer := 456; + -- exception + -- when Cain => + -- Put(X); + -- end P; + -- + -- It was proposed that in the handler, X should refer to the outer + -- X, but that's just confusing. + + if Token = Tok_Exception then + Error_Msg + ("declarative item in statements conflicts with " & + "exception handler below", + Decl_Loc); + Error_Msg + ("exception handler conflicts with " & + "declarative item in statements above", + Token_Ptr); + end if; + + if Handled then + return Statement_List; + else + declare + Loc : constant Source_Ptr := Sloc (First (Statement_List)); + Block : constant Node_Id := + Make_Block_Statement + (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, Statements => Statement_List)); + begin + return New_List (Block); + end; + end if; + else + return Statement_List; + end if; end P_Sequence_Of_Statements; -------------------- diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 88f27f0..e1cf5ba 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -65,7 +65,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is -- the routine for the argument one past the last present argument, but -- that is the only case in which a non-present argument can be referenced. - procedure Check_Arg_Count (Required : Int); + procedure Check_Arg_Count (Required : Nat); -- Check argument count for pragma = Required. If not give error and raise -- Error_Resync. @@ -155,7 +155,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is -- Check_Arg_Count -- --------------------- - procedure Check_Arg_Count (Required : Int) is + procedure Check_Arg_Count (Required : Nat) is begin if Arg_Count /= Required then Error_Msg_N ("wrong number of arguments for pragma%", Pragma_Node); diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 20b2df9..b6ffdae 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -701,6 +701,28 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Subtype_Mark_Resync return Node_Id; function P_Unknown_Discriminant_Part_Opt return Boolean; + procedure P_Declarative_Items + (Decls : List_Id; + Declare_Expression : Boolean; + In_Spec : Boolean; + In_Statements : Boolean); + -- Parses a sequence of zero or more declarative items, and appends them + -- to Decls. Done indicates whether or not there might be additional + -- declarative items to parse. If Done is True, then there are no more + -- to parse; otherwise there might be more. + -- + -- Declare_Expression is true if we are parsing a declare_expression, in + -- which case we want to suppress certain style checking. + -- + -- In_Spec is true if we are scanning a package declaration, and is used + -- to generate an appropriate message if a statement is encountered in + -- such a context. + -- + -- In_Statements is true if we are called to parse declarative items in + -- a sequence of statements. In this case, we do not give an error upon + -- encountering a statement, but return to the caller with Done = True, + -- so the caller can resume parsing statements. + function P_Basic_Declarative_Items (Declare_Expression : Boolean) return List_Id; -- Used to parse the declarative items in a package visible or @@ -858,9 +880,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Loop_Parameter_Specification return Node_Id; -- Used in loop constructs and quantified expressions. - function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id; + function P_Sequence_Of_Statements + (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id; -- The argument indicates the acceptable termination tokens. -- See body in Par.Ch5 for details of the use of this parameter. + -- Handled is true if we are parsing a handled sequence of statements. procedure Parse_Decls_Begin_End (Parent : Node_Id); -- Parses declarations and handled statement sequence, setting diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index d62572e..cf43ca9 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -44,10 +44,6 @@ with Uname; use Uname; package body Restrict is - Global_Restriction_No_Tasking : Boolean := False; - -- Set to True when No_Tasking is set in the run-time package System - -- or in a configuration pragmas file (for example, gnat.adc). - -------------------------------- -- Package Local Declarations -- -------------------------------- @@ -55,6 +51,10 @@ package body Restrict is Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; -- Save compilation unit restrictions set by config pragma files + Global_Restriction_No_Tasking : Boolean := False; + -- Set to True when No_Tasking is set in the run-time package System + -- or in a configuration pragmas file (for example, gnat.adc). + Restricted_Profile_Result : Boolean := False; -- This switch memoizes the result of Restricted_Profile function calls for -- improved efficiency. Valid only if Restricted_Profile_Cached is True. @@ -122,6 +122,11 @@ package body Restrict is -- message is to be suppressed if this is an internal file and this file is -- not the main unit. Returns True if message is to be suppressed. + procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id); + -- Called if a violation of restriction No_Dependence for Unit at node N + -- is found. This routine outputs the appropriate message, taking care of + -- warning vs real violation. + ------------------- -- Abort_Allowed -- ------------------- @@ -550,8 +555,6 @@ package body Restrict is ------------------------------------- procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is - DU : Node_Id; - begin -- Ignore call if node U is not in the main source unit. This avoids -- cascaded errors, e.g. when Ada.Containers units with other units. @@ -567,26 +570,33 @@ package body Restrict is -- Loop through entries in No_Dependence table to check each one in turn for J in No_Dependences.First .. No_Dependences.Last loop - DU := No_Dependences.Table (J).Unit; + if Same_Unit (No_Dependences.Table (J).Unit, U) then + Violation_Of_No_Dependence (J, Err); + return; + end if; + end loop; + end Check_Restriction_No_Dependence; - if Same_Unit (U, DU) then - Error_Msg_Sloc := Sloc (DU); - Error_Msg_Node_1 := DU; + ----------------------------------------------- + -- Check_Restriction_No_Dependence_On_System -- + ----------------------------------------------- - if No_Dependences.Table (J).Warn then - Error_Msg - ("?*?violation of restriction `No_Dependence '='> &`#", - Sloc (Err)); - else - Error_Msg - ("|violation of restriction `No_Dependence '='> &`#", - Sloc (Err)); - end if; + procedure Check_Restriction_No_Dependence_On_System + (U : Name_Id; + Err : Node_Id) + is + pragma Assert (U /= No_Name); + + begin + -- Loop through entries in No_Dependence table to check each one in turn + for J in No_Dependences.First .. No_Dependences.Last loop + if No_Dependences.Table (J).System_Child = U then + Violation_Of_No_Dependence (J, Err); return; end if; end loop; - end Check_Restriction_No_Dependence; + end Check_Restriction_No_Dependence_On_System; -------------------------------------------------- -- Check_Restriction_No_Specification_Of_Aspect -- @@ -1474,6 +1484,8 @@ package body Restrict is Warn : Boolean; Profile : Profile_Name := No_Profile) is + ND : ND_Entry; + begin -- Loop to check for duplicate entry @@ -1495,7 +1507,26 @@ package body Restrict is -- Entry is not currently in table - No_Dependences.Append ((Unit, Warn, Profile)); + ND := (Unit, No_Name, Warn, Profile); + + -- Check whether this is a child unit of System + + if Nkind (Unit) = N_Selected_Component then + declare + Root : Node_Id := Unit; + + begin + while Nkind (Prefix (Root)) = N_Selected_Component loop + Root := Prefix (Root); + end loop; + + if Chars (Prefix (Root)) = Name_System then + ND.System_Child := Chars (Selector_Name (Root)); + end if; + end; + end if; + + No_Dependences.Append (ND); end Set_Restriction_No_Dependence; -------------------------------------- @@ -1647,6 +1678,24 @@ package body Restrict is end if; end Suppress_Restriction_Message; + -------------------------------- + -- Violation_Of_No_Dependence -- + -------------------------------- + + procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id) is + begin + Error_Msg_Node_1 := No_Dependences.Table (Unit).Unit; + Error_Msg_Sloc := Sloc (Error_Msg_Node_1); + + if No_Dependences.Table (Unit).Warn then + Error_Msg + ("?*?violation of restriction `No_Dependence '='> &`#", Sloc (N)); + else + Error_Msg + ("|violation of restriction `No_Dependence '='> &`#", Sloc (N)); + end if; + end Violation_Of_No_Dependence; + --------------------- -- Tasking_Allowed -- --------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 040e83c..7a5c0ff 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -168,6 +168,9 @@ package Restrict is Unit : Node_Id; -- The unit parameter from the No_Dependence pragma + System_Child : Name_Id; + -- The name if the unit is a child of System, or else No_Name + Warn : Boolean; -- True if from Restriction_Warnings, False if from Restrictions @@ -269,6 +272,13 @@ package Restrict is -- an explicit WITH clause). U is a node for the unit involved, and Err is -- the node to which an error will be attached if necessary. + procedure Check_Restriction_No_Dependence_On_System + (U : Name_Id; + Err : Node_Id); + -- Likewise, but for the child units of System referenced by their name + + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id); -- N is the node id for an N_Aspect_Specification, an N_Pragma, or an -- N_Attribute_Definition_Clause. An error message (warning) will be issued diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1270955..65c6409 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -910,15 +910,6 @@ package Rtsfind is RE_Str_Concat_8, -- System.Concat_8 RE_Str_Concat_9, -- System.Concat_9 - RE_Str_Concat_Bounds_2, -- System.Concat_2 - RE_Str_Concat_Bounds_3, -- System.Concat_3 - RE_Str_Concat_Bounds_4, -- System.Concat_4 - RE_Str_Concat_Bounds_5, -- System.Concat_5 - RE_Str_Concat_Bounds_6, -- System.Concat_6 - RE_Str_Concat_Bounds_7, -- System.Concat_7 - RE_Str_Concat_Bounds_8, -- System.Concat_8 - RE_Str_Concat_Bounds_9, -- System.Concat_9 - RE_Get_Active_Partition_Id, -- System.DSA_Services RE_Get_Local_Partition_Id, -- System.DSA_Services RE_Get_Passive_Partition_Id, -- System.DSA_Services @@ -2608,15 +2599,6 @@ package Rtsfind is RE_Str_Concat_8 => System_Concat_8, RE_Str_Concat_9 => System_Concat_9, - RE_Str_Concat_Bounds_2 => System_Concat_2, - RE_Str_Concat_Bounds_3 => System_Concat_3, - RE_Str_Concat_Bounds_4 => System_Concat_4, - RE_Str_Concat_Bounds_5 => System_Concat_5, - RE_Str_Concat_Bounds_6 => System_Concat_6, - RE_Str_Concat_Bounds_7 => System_Concat_7, - RE_Str_Concat_Bounds_8 => System_Concat_8, - RE_Str_Concat_Bounds_9 => System_Concat_9, - RE_Get_Active_Partition_Id => System_DSA_Services, RE_Get_Local_Partition_Id => System_DSA_Services, RE_Get_Passive_Partition_Id => System_DSA_Services, diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index d73dae4..dbe9e5a 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -210,15 +210,11 @@ package Scans is Tok_End_Of_Line, -- Represents an end of line. Not used during normal compilation scans - -- where end of line is ignored. Active for preprocessor scanning and - -- also when scanning project files (where it is needed because of ???) + -- where end of line is ignored. Active for preprocessor scanning. Tok_Special, - -- AI12-0125-03 : target name as abbreviation for LHS - - -- Otherwise used only in preprocessor scanning (to represent one of - -- the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The - -- character value itself is stored in Scans.Special_Character. + -- Special character used by the preprocessor. The character itself is + -- stored in Special_Character below. No_Token); -- No_Token is used for initializing Token values to indicate that @@ -466,12 +462,9 @@ package Scans is -- character found (i.e. a character that does not fit in Character or -- Wide_Character). - Special_Character : Character; - -- AI12-0125-03 : '@' as target name is handled elsewhere. - -- Valid only when Token = Tok_Special. Returns one of the characters - -- '#', '$', '?', '`', '\', '^', '~', or '_'. - -- - -- Why only this set? What about wide characters??? + subtype Special_Preprocessor_Character is Character with + Predicate => Special_Preprocessor_Character in '#' | '$'; + Special_Character : Special_Preprocessor_Character; Comment_Id : Name_Id := No_Name; -- Valid only when Token = Tok_Comment. Store the string that follows diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads index 1f224c3..40ece8f 100644 --- a/gcc/ada/scn.ads +++ b/gcc/ada/scn.ads @@ -29,7 +29,7 @@ with Casing; use Casing; with Errout; use Errout; with Scng; -with Style; -- use Style; +with Style; with Types; use Types; package Scn is @@ -75,9 +75,5 @@ package Scn is Style => Style.Style_Inst); procedure Scan renames Scanner.Scan; - -- Scan scans out the next token, and advances the scan state accordingly - -- (see package Scans for details). If the scan encounters an illegal - -- token, then an error message is issued pointing to the bad character, - -- and Scan returns a reasonable substitute token of some kind. end Scn; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index cd10d1d..f5fc020 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -27,9 +27,9 @@ with Atree; use Atree; with Csets; use Csets; with Errout; use Errout; with Hostparm; use Hostparm; +with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; -with Scans; use Scans; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; @@ -53,9 +53,6 @@ package body Scng is Special_Characters : array (Character) of Boolean := (others => False); -- For characters that are Special token, the value is True - Comment_Is_Token : Boolean := False; - -- True if comments are tokens - End_Of_Line_Is_Token : Boolean := False; -- True if End_Of_Line is a token @@ -259,9 +256,6 @@ package body Scng is procedure Scan is - Start_Of_Comment : Source_Ptr; - -- Record start of comment position - Underline_Found : Boolean; -- During scanning of an identifier, set to True if last character -- scanned was an underline or other punctuation character. This @@ -1609,10 +1603,6 @@ package body Scng is return; end if; - -- Otherwise scan out the comment - - Start_Of_Comment := Scan_Ptr; - -- Loop to scan comment (this loop runs more than once only if -- a horizontal tab or other non-graphic character is scanned) @@ -1711,18 +1701,8 @@ package body Scng is end if; end loop; - -- Note that, except when comments are tokens, we do NOT - -- execute a return here, instead we fall through to reexecute - -- the scan loop to look for a token. - - if Comment_Is_Token then - Name_Len := Integer (Scan_Ptr - Start_Of_Comment); - Name_Buffer (1 .. Name_Len) := - String (Source (Start_Of_Comment .. Scan_Ptr - 1)); - Comment_Id := Name_Find; - Token := Tok_Comment; - return; - end if; + -- Note that we do not return here; instead we fall through to + -- reexecute the scan loop to look for a token. end if; end Minus_Case; @@ -2072,15 +2052,15 @@ package body Scng is -- Underline character when '_' => - if Special_Characters ('_') then - Token_Ptr := Scan_Ptr; - Scan_Ptr := Scan_Ptr + 1; - Token := Tok_Special; - Special_Character := '_'; - return; + -- Identifiers with leading underscores are not allowed in Ada. + -- However, we allow them in the run-time library, so we can + -- create names that are hidden from normal Ada code. For an + -- example, search for "Name_uNext", which is "_Next". + + if not In_Internal_Unit (Scan_Ptr) then + Error_Msg_S ("identifier cannot start with underline"); end if; - Error_Msg_S ("identifier cannot start with underline"); Name_Len := 1; Name_Buffer (1) := '_'; Scan_Ptr := Scan_Ptr + 1; @@ -2132,42 +2112,19 @@ package body Scng is Error_Illegal_Character; end if; - -- Invalid control characters - - when ACK - | ASCII.SO - | BEL - | BS - | CAN - | DC1 - | DC2 - | DC3 - | DC4 - | DEL - | DLE - | EM - | ENQ - | EOT - | ETB - | ETX - | FS - | GS - | NAK - | NUL - | RS - | SI - | SOH - | STX - | SYN - | US + -- Illegal characters + + when ACK | ASCII.SO | BEL | BS | CAN | DC1 | DC2 | DC3 | DC4 | DEL + | DLE | EM | ENQ | EOT | ETB | ETX | FS | GS | NAK | NUL | RS | SI + | SOH | STX | SYN | US + | '?' | '`' | '\' | '^' | '~' => Error_Illegal_Character; - -- Invalid graphic characters - -- Note that '@' is handled elsewhere, because following AI12-125 - -- it denotes the target_name of an assignment. + -- Special preprocessor characters. If Set_Special_Character has been + -- called, return a Special token. Otherwise give an error. - when '#' | '$' | '?' | '`' | '\' | '^' | '~' => + when Special_Preprocessor_Character => -- If Set_Special_Character has been called for this character, -- set Scans.Special_Character and return a Special token. @@ -2710,15 +2667,6 @@ package body Scng is end if; end Scan; - -------------------------- - -- Set_Comment_As_Token -- - -------------------------- - - procedure Set_Comment_As_Token (Value : Boolean) is - begin - Comment_Is_Token := Value; - end Set_Comment_As_Token; - ------------------------------ -- Set_End_Of_Line_As_Token -- ------------------------------ @@ -2732,15 +2680,9 @@ package body Scng is -- Set_Special_Character -- --------------------------- - procedure Set_Special_Character (C : Character) is + procedure Set_Special_Character (C : Special_Preprocessor_Character) is begin - case C is - when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' => - Special_Characters (C) := True; - - when others => - null; - end case; + Special_Characters (C) := True; end Set_Special_Character; ---------------------- diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index 9399997..fcce36b 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -23,11 +23,11 @@ -- -- ------------------------------------------------------------------------------ --- This package contains a generic lexical analyzer. This is used for scanning --- Ada source files or text files with an Ada-like syntax, such as project --- files. It is instantiated in Scn and Prj.Err. +-- This is a generic lexical analyzer, used for scanning Ada source files, and +-- also for preprocessor files. with Casing; use Casing; +with Scans; use Scans; with Styleg; with Types; use Types; @@ -68,33 +68,27 @@ package Scng is -- Scan scans out the next token, and advances the scan state accordingly -- (see package Scan_State for details). If the scan encounters an illegal -- token, then an error message is issued pointing to the bad character, - -- and Scan returns a reasonable substitute token of some kind. - -- For tokens Char_Literal, Identifier, Real_Literal, Integer_Literal, - -- String_Literal and Operator_Symbol, Post_Scan is called after scanning. + -- and Scan returns a reasonable substitute token. For tokens Char_Literal, + -- Identifier, Real_Literal, Integer_Literal, String_Literal and + -- Operator_Symbol, Post_Scan is called after scanning. function Determine_Token_Casing return Casing_Type; pragma Inline (Determine_Token_Casing); -- Determines the casing style of the current token, which is -- either a keyword or an identifier. See also package Casing. - procedure Set_Special_Character (C : Character); - -- Indicate that one of the following character '#', '$', '?', '`', - -- '\', '^', '_' or '~', when found is a Special token. - -- AI12-0125-03 : target name (ES) is not in this list because '@' is - -- handled as a special token as abbreviation of LHS of assignment. + procedure Set_Special_Character (C : Special_Preprocessor_Character); + -- Called when the preprocessor is active to indicate that Scan should + -- return a Special token for C. procedure Reset_Special_Characters; - -- Indicate that there is no characters that are Special tokens., which + -- Indicate that there are no characters that are Special tokens, which -- is the default. procedure Set_End_Of_Line_As_Token (Value : Boolean); -- Indicate if End_Of_Line is a token or not. -- By default, End_Of_Line is not a token. - procedure Set_Comment_As_Token (Value : Boolean); - -- Indicate if a comment is a token or not. - -- By default, a comment is not a token. - function Set_Start_Column return Column_Number; -- This routine is called with Scan_Ptr pointing to the first character -- of a line. On exit, Scan_Ptr is advanced to the first non-blank diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 796fffb..6c1e9d7 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1338,7 +1338,15 @@ package body Sem is Full_Analysis := False; Expander_Mode_Save_And_Set (False); - Analyze (N); + -- See comment in sem_res.adb for Preanalyze_And_Resolve + + if GNATprove_Mode + or else Nkind (Parent (N)) = N_Simple_Return_Statement + then + Analyze (N); + else + Analyze (N, Suppress => All_Checks); + end if; Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cab2461..93bb6f4 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1508,9 +1508,9 @@ package body Sem_Attr is and then Chars (Spec_Id) = Name_uParent and then Chars (Scope (Spec_Id)) = Name_uPostconditions then - -- This situation occurs only when preanalyzing the inlined body + -- This situation occurs only when analyzing the body-to-inline - pragma Assert (not Full_Analysis); + pragma Assert (Inside_A_Generic); Spec_Id := Scope (Spec_Id); pragma Assert (Is_Inlined (Spec_Id)); @@ -12778,13 +12778,8 @@ package body Sem_Attr is ------------------------ procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is - Loc : constant Source_Ptr := Sloc (N); begin - if B then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; + Rewrite (N, New_Occurrence_Of (Boolean_Literals (B), Sloc (N))); end Set_Boolean_Result; -------------------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index af8bbbe..9525140 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1113,7 +1113,7 @@ package body Sem_Ch12 is Analyzed_Formal : Node_Id; First_Named : Node_Id := Empty; Formal : Node_Id; - Match : Node_Id; + Match : Node_Id := Empty; Named : Node_Id; Saved_Formal : Node_Id; @@ -4297,7 +4297,6 @@ package body Sem_Ch12 is if Nkind (N) = N_Package_Instantiation then Act_Decl_Id := New_Copy (Defining_Entity (N)); - Set_Comes_From_Source (Act_Decl_Id, True); if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then Act_Decl_Name := diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bb654ab..a64a3cd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -23,59 +23,60 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Contracts; use Contracts; -with Debug; use Debug; -with Einfo; use Einfo; -with Einfo.Entities; use Einfo.Entities; -with Einfo.Utils; use Einfo.Utils; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Ch3; use Exp_Ch3; -with Exp_Disp; use Exp_Disp; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Case; use Sem_Case; -with Sem_Cat; use Sem_Cat; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Dim; use Sem_Dim; -with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Sinfo; use Sinfo; -with Sinfo.Nodes; use Sinfo.Nodes; -with Sinfo.Utils; use Sinfo.Utils; -with Sinput; use Sinput; -with Snames; use Snames; -with Stand; use Stand; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Contracts; use Contracts; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; +with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with System.Case_Util; use System.Case_Util; with Table; -with Targparm; use Targparm; -with Ttypes; use Ttypes; -with Tbuild; use Tbuild; -with Urealp; use Urealp; -with Warnsw; use Warnsw; +with Targparm; use Targparm; +with Ttypes; use Ttypes; +with Tbuild; use Tbuild; +with Urealp; use Urealp; +with Warnsw; use Warnsw; with GNAT.Heap_Sort_G; @@ -1650,6 +1651,18 @@ package body Sem_Ch13 is -- pragma of the same kind. Flag Is_Generic should be set when the -- context denotes a generic instance. + function Relocate_Expression (Source : Node_Id) return Node_Id; + -- Outside of a generic this function is equivalent to Relocate_Node. + -- Inside a generic it is an identity function, because Relocate_Node + -- would create a new node that is not associated with the generic + -- template. This association is needed to save references to entities + -- that are global to the generic (and might be not visible from where + -- the generic is instantiated). + -- + -- Inside a generic the original tree is shared between aspect and + -- a corresponding pragma (or an attribute definition clause). This + -- parallels what is done in sem_prag.adb (see Get_Argument). + -------------- -- Decorate -- -------------- @@ -1835,6 +1848,19 @@ package body Sem_Ch13 is end if; end Insert_Pragma; + ------------------------- + -- Relocate_Expression -- + ------------------------- + + function Relocate_Expression (Source : Node_Id) return Node_Id is + begin + if Inside_A_Generic then + return Source; + else + return Atree.Relocate_Node (Source); + end if; + end Relocate_Expression; + -- Local variables Aspect : Node_Id; @@ -2724,13 +2750,11 @@ package body Sem_Ch13 is Expr_Value : Boolean := False; begin - -- Check valid declarations for 'Yield + -- Check valid entity for 'Yield - if Nkind (N) in N_Abstract_Subprogram_Declaration - | N_Entry_Declaration - | N_Generic_Subprogram_Declaration - | N_Subprogram_Declaration - | N_Formal_Subprogram_Declaration + if (Is_Subprogram (E) + or else Is_Generic_Subprogram (E) + or else Is_Entry (E)) and then not Within_Protected_Type (E) then null; @@ -3231,7 +3255,7 @@ package body Sem_Ch13 is Make_Attribute_Definition_Clause (Loc, Name => Ent, Chars => Nam, - Expression => Relocate_Node (Expr)); + Expression => Relocate_Expression (Expr)); -- If the address is specified, then we treat the entity as -- referenced, to avoid spurious warnings. This is analogous @@ -3295,7 +3319,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), + Expression => Relocate_Expression (Expr))), Pragma_Name => Name_Attach_Handler); -- We need to insert this pragma into the tree to get proper @@ -3337,7 +3361,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), + Expression => Relocate_Expression (Expr))), Pragma_Name => Name_Predicate); -- Mark type has predicates, and remember what kind of @@ -3582,7 +3606,7 @@ package body Sem_Ch13 is Make_Attribute_Definition_Clause (Loc, Name => Ent, Chars => Nam, - Expression => Relocate_Node (Expr)); + Expression => Relocate_Expression (Expr)); end if; -- Suppress/Unsuppress @@ -4601,32 +4625,12 @@ package body Sem_Ch13 is -- Build the precondition/postcondition pragma - -- We use Relocate_Node here rather than New_Copy_Tree - -- because subsequent visibility analysis of the aspect - -- depends on this sharing. This should be cleaned up??? - - -- If the context is generic, we want to preserve the - -- original tree, and simply share it between aspect and - -- generated attribute. This parallels what is done in - -- sem_prag.adb (see Get_Argument). - - declare - New_Expr : Node_Id; - - begin - if Inside_A_Generic then - New_Expr := Expr; - else - New_Expr := Relocate_Node (Expr); - end if; - - Aitem := Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Eloc, - Chars => Name_Check, - Expression => New_Expr)), - Pragma_Name => Pname); - end; + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => Relocate_Expression (Expr))), + Pragma_Name => Pname); -- Add message unless exception messages are suppressed @@ -11353,6 +11357,16 @@ package body Sem_Ch13 is return; when Aspect_Storage_Model_Type => + + -- The aggregate argument of Storage_Model_Type is optional, and + -- when not present the aspect defaults to the native storage + -- model (where the address type is System.Address, and other + -- arguments default to corresponding native storage operations). + + if No (Expression (ASN)) then + return; + end if; + T := Entity (ASN); declare @@ -16556,12 +16570,14 @@ package body Sem_Ch13 is return; + -- If Addr_Type is not present as the first association, then we default + -- it to System.Address. + elsif not Present (Addr_Type) then - Error_Msg_N ("argument association for Address_Type missing; " - & "must be specified as first aspect argument", N); - return; + Addr_Type := RTE (RE_Address); + end if; - elsif Nam = Name_Null_Address then + if Nam = Name_Null_Address then if not Is_Entity_Name (N) or else not Is_Constant_Object (Entity (N)) or else @@ -17332,9 +17348,10 @@ package body Sem_Ch13 is procedure Validate_Storage_Model_Type_Aspect (Typ : Entity_Id; ASN : Node_Id) is - Assoc : Node_Id; - Choice : Entity_Id; - Expr : Node_Id; + Assoc : Node_Id; + Choice : Entity_Id; + Choice_Name : Name_Id; + Expr : Node_Id; Address_Type_Id : Entity_Id := Empty; Null_Address_Id : Entity_Id := Empty; @@ -17344,7 +17361,49 @@ package body Sem_Ch13 is Copy_To_Id : Entity_Id := Empty; Storage_Size_Id : Entity_Id := Empty; + procedure Check_And_Resolve_Storage_Model_Type_Argument + (Expr : Node_Id; + Typ : Entity_Id; + Argument_Id : in out Entity_Id; + Nam : Name_Id); + -- Checks that the subaspect for Nam has not already been specified for + -- Typ's Storage_Model_Type aspect (i.e., checks Argument_Id = Empty), + -- resolves Expr, and sets Argument_Id to the entity resolved for Expr. + + procedure Check_And_Resolve_Storage_Model_Type_Argument + (Expr : Node_Id; + Typ : Entity_Id; + Argument_Id : in out Entity_Id; + Nam : Name_Id) + is + Name_String : String := Get_Name_String (Nam); + + begin + To_Mixed (Name_String); + + if Present (Argument_Id) then + Error_Msg_String (1 .. Name_String'Length) := Name_String; + Error_Msg_Strlen := Name_String'Length; + + Error_Msg_N ("~ already specified", Expr); + end if; + + Resolve_Storage_Model_Type_Argument (Expr, Typ, Address_Type_Id, Nam); + Argument_Id := Entity (Expr); + end Check_And_Resolve_Storage_Model_Type_Argument; + + -- Start of processing for Validate_Storage_Model_Type_Aspect + begin + -- The aggregate argument of Storage_Model_Type is optional, and when + -- not present the aspect defaults to the native storage model (where + -- the address type is System.Address, and other arguments default to + -- the corresponding native storage operations). + + if No (Expression (ASN)) then + return; + end if; + -- Each expression must resolve to an entity of the right kind or proper -- profile. @@ -17355,65 +17414,67 @@ package body Sem_Ch13 is Choice := First (Choices (Assoc)); + Choice_Name := Chars (Choice); + if Nkind (Choice) /= N_Identifier or else Present (Next (Choice)) then Error_Msg_N ("illegal name in association", Choice); - elsif Chars (Choice) = Name_Address_Type then + elsif Choice_Name = Name_Address_Type then if Assoc /= First (Component_Associations (Expression (ASN))) then Error_Msg_N ("Address_Type must be first association", Choice); end if; - Resolve_Storage_Model_Type_Argument + Check_And_Resolve_Storage_Model_Type_Argument (Expr, Typ, Address_Type_Id, Name_Address_Type); - Address_Type_Id := Entity (Expr); - -- Shouldn't we check for duplicates of the same subaspect name, - -- and issue an error in such cases??? + else + -- It's allowed to leave out the Address_Type argument, in which + -- case the address type is defined to default to System.Address. - elsif not Present (Address_Type_Id) then - Error_Msg_N - ("Address_Type missing, must be first association", Choice); - - elsif Chars (Choice) = Name_Null_Address then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Null_Address); - Null_Address_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Allocate then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Allocate); - Allocate_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Deallocate then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Deallocate); - Deallocate_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Copy_From then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Copy_From); - Copy_From_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Copy_To then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Copy_To); - Copy_To_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Storage_Size then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Storage_Size); - Storage_Size_Id := Entity (Expr); + if No (Address_Type_Id) then + Address_Type_Id := RTE (RE_Address); + end if; - else - Error_Msg_N - ("invalid name for Storage_Model_Type argument", Choice); + if Choice_Name = Name_Null_Address then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Null_Address_Id, Name_Null_Address); + + elsif Choice_Name = Name_Allocate then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Allocate_Id, Name_Allocate); + + elsif Choice_Name = Name_Deallocate then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Deallocate_Id, Name_Deallocate); + + elsif Choice_Name = Name_Copy_From then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Copy_From_Id, Name_Copy_From); + + elsif Choice_Name = Name_Copy_To then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Copy_To_Id, Name_Copy_To); + + elsif Choice_Name = Name_Storage_Size then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Storage_Size_Id, Name_Storage_Size); + + else + Error_Msg_N + ("invalid name for Storage_Model_Type argument", Choice); + end if; end if; Next (Assoc); end loop; - if No (Address_Type_Id) then - Error_Msg_N ("match for Address_Type not found", ASN); + -- If Address_Type has been specified as or defaults to System.Address, + -- then other "subaspect" arguments can be specified, but are optional. + -- Otherwise, all other arguments are required and an error is flagged + -- about any that are missing. + + if Address_Type_Id = RTE (RE_Address) then + return; elsif No (Null_Address_Id) then Error_Msg_N ("match for Null_Address primitive not found", ASN); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 891c57a..e1b5722 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -4393,6 +4393,31 @@ package body Sem_Ch5 is ---------------------------- procedure Check_Unreachable_Code (N : Node_Id) is + + function Is_Simple_Case (N : Node_Id) return Boolean; + -- N is the condition of an if statement. True if N is simple enough + -- that we should not set Unblocked_Exit_Count in the special case + -- below. + + -------------------- + -- Is_Simple_Case -- + -------------------- + + function Is_Simple_Case (N : Node_Id) return Boolean is + begin + return + Is_Trivial_Boolean (N) + or else + (Comes_From_Source (N) + and then Is_Static_Expression (N) + and then Nkind (N) in N_Identifier | N_Expanded_Name + and then Ekind (Entity (N)) = E_Constant) + or else + (not In_Instance + and then Nkind (Original_Node (N)) = N_Op_Not + and then Is_Simple_Case (Right_Opnd (Original_Node (N)))); + end Is_Simple_Case; + Error_Node : Node_Id; Nxt : Node_Id; P : Node_Id; @@ -4418,12 +4443,20 @@ package body Sem_Ch5 is elsif Comes_From_Source (Nxt) and then Is_Statement (Nxt) then - -- Special very annoying exception. If we have a return that - -- follows a raise, then we allow it without a warning, since - -- the Ada RM annoyingly requires a useless return here. - - if Nkind (Original_Node (N)) /= N_Raise_Statement - or else Nkind (Nxt) /= N_Simple_Return_Statement + -- Special very annoying exception. Ada RM 6.5(5) annoyingly + -- requires functions to have at least one return statement, so + -- don't complain about a simple return that follows a raise or a + -- call to procedure with No_Return. + + if not (Present (Current_Subprogram) + and then Ekind (Current_Subprogram) = E_Function + and then (Nkind (N) in N_Raise_Statement + or else + (Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Present (Entity (Name (N))) + and then No_Return (Entity (Name (N))))) + and then Nkind (Nxt) = N_Simple_Return_Statement) then -- The rather strange shenanigans with the warning message -- here reflects the fact that Kill_Dead_Code is very good at @@ -4436,39 +4469,59 @@ package body Sem_Ch5 is -- unreachable code, since it is useless and we don't want -- to generate junk warnings. - -- We skip this step if we are not in code generation mode - -- or CodePeer mode. + -- We skip this step if we are not in code generation mode. -- This is the one case where we remove dead code in the -- semantics as opposed to the expander, and we do not want -- to remove code if we are not in code generation mode, since -- this messes up the tree or loses useful information for - -- CodePeer. + -- analysis tools such as CodePeer. -- Note that one might react by moving the whole circuit to -- exp_ch5, but then we lose the warning in -gnatc mode. - if Operating_Mode = Generate_Code - and then not CodePeer_Mode - then + if Operating_Mode = Generate_Code then loop - Nxt := Next (N); - - -- Quit deleting when we have nothing more to delete - -- or if we hit a label (since someone could transfer - -- control to a label, so we should not delete it). + declare + Del : constant Node_Id := Next (N); + -- Node to be possibly deleted + begin + -- Quit deleting when we have nothing more to delete + -- or if we hit a label (since someone could transfer + -- control to a label, so we should not delete it). - exit when No (Nxt) or else Nkind (Nxt) = N_Label; + exit when No (Del) or else Nkind (Del) = N_Label; - -- Statement/declaration is to be deleted + -- Statement/declaration is to be deleted - Analyze (Nxt); - Remove (Nxt); - Kill_Dead_Code (Nxt); + Analyze (Del); + Kill_Dead_Code (Del); + Remove (Del); + end; end loop; + + -- If this is a function, we add "raise Program_Error;", + -- because otherwise, we will get incorrect warnings about + -- falling off the end of the function. + + declare + Subp : constant Entity_Id := Current_Subprogram; + begin + if Present (Subp) and then Ekind (Subp) = E_Function then + Insert_After_And_Analyze (N, + Make_Raise_Program_Error (Sloc (Error_Node), + Reason => PE_Missing_Return)); + end if; + end; + end if; - Error_Msg_N ("??unreachable code!", Error_Node); + -- Suppress the warning in instances, because a statement can + -- be unreachable in some instances but not others. + + if not In_Instance then + Error_Msg_N ("??unreachable code!", Error_Node); + end if; end if; -- If the unconditional transfer of control instruction is the @@ -4527,9 +4580,32 @@ package body Sem_Ch5 is end if; -- This was one of the cases we are looking for (i.e. the parent - -- construct was IF, CASE or block) so decrement count. - - Unblocked_Exit_Count := Unblocked_Exit_Count - 1; + -- construct was IF, CASE or block). In most cases, we simply + -- decrement the count. However, if the parent is something like: + -- + -- if cond then + -- raise ...; -- or some other jump + -- end if; + -- + -- where cond is an expression that is known-true at compile time, + -- we can treat that as just the jump -- i.e. anything following + -- the if statement is unreachable. We don't do this for simple + -- cases like "if True" or "if Debug_Flag", because that causes + -- too many warnings. + + if Nkind (P) = N_If_Statement + and then Present (Then_Statements (P)) + and then No (Elsif_Parts (P)) + and then No (Else_Statements (P)) + and then Is_OK_Static_Expression (Condition (P)) + and then Is_True (Expr_Value (Condition (P))) + and then not Is_Simple_Case (Condition (P)) + then + pragma Assert (Unblocked_Exit_Count = 2); + Unblocked_Exit_Count := 0; + else + Unblocked_Exit_Count := Unblocked_Exit_Count - 1; + end if; end if; end if; end Check_Unreachable_Code; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8334647..e4af71c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4508,7 +4508,16 @@ package body Sem_Ch6 is -- This also needs to be done in the case of an ignored Ghost -- expression function, where the expander isn't active. - Set_Is_Frozen (Spec_Id); + -- A further complication arises if the expression function is + -- a primitive operation of a tagged type: in that case the + -- function entity must be frozen before the dispatch table for + -- the type is constructed, so it will be frozen like other local + -- entities, at the end of the current scope. + + if not Is_Dispatching_Operation (Spec_Id) then + Set_Is_Frozen (Spec_Id); + end if; + Mask_Types := Mask_Unfrozen_Types (Spec_Id); elsif not Is_Frozen (Spec_Id) @@ -4734,6 +4743,12 @@ package body Sem_Ch6 is Style.Body_With_No_Spec (N); end if; + -- First set Acts_As_Spec if appropriate + + if Nkind (N) /= N_Subprogram_Body_Stub then + Set_Acts_As_Spec (N); + end if; + New_Overloaded_Entity (Body_Id); -- A subprogram body should cause freezing of its own declaration, @@ -4758,7 +4773,6 @@ package body Sem_Ch6 is end if; if Nkind (N) /= N_Subprogram_Body_Stub then - Set_Acts_As_Spec (N); Generate_Definition (Body_Id); Generate_Reference (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); @@ -7555,6 +7569,8 @@ package body Sem_Ch6 is Err : out Boolean; Proc : Entity_Id := Empty) is + pragma Assert (Mode in 'F' | 'P'); + pragma Assert (if Mode = 'F' then No (Proc)); Handler : Node_Id; procedure Check_Statement_Sequence (L : List_Id); @@ -7604,15 +7620,13 @@ package body Sem_Ch6 is -- Local variables - Raise_Exception_Call : Boolean; + Raise_Exception_Call : Boolean := False; -- Set True if statement sequence terminated by Raise_Exception call -- or a Reraise_Occurrence call. -- Start of processing for Check_Statement_Sequence begin - Raise_Exception_Call := False; - -- Get last real statement Last_Stm := Last (L); @@ -7678,7 +7692,8 @@ package body Sem_Ch6 is while Nkind (Last_Stm) = N_Pragma - -- Don't count call to SS_Release (can happen after Raise_Exception) + -- Don't count call to SS_Release (can happen after + -- Raise_Exception). or else (Nkind (Last_Stm) = N_Procedure_Call_Statement @@ -7687,7 +7702,7 @@ package body Sem_Ch6 is and then Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release)) - -- Don't count exception junk + -- Don't count exception junk or else (Nkind (Last_Stm) in @@ -7695,10 +7710,12 @@ package body Sem_Ch6 is and then Exception_Junk (Last_Stm)) or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label - -- Inserted code, such as finalization calls, is irrelevant: we only - -- need to check original source. + -- Inserted code, such as finalization calls, is irrelevant; we + -- only need to check original source. If we see a transfer of + -- control, we stop. - or else Is_Rewrite_Insertion (Last_Stm) + or else (Is_Rewrite_Insertion (Last_Stm) + and then not Is_Transfer (Last_Stm)) loop Prev (Last_Stm); end loop; @@ -9513,15 +9530,85 @@ package body Sem_Ch6 is ----------------------------- procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is - Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); - Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); - Obj_Decl : Node_Id; + Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + + procedure Freezing_Point_Warning (N : Node_Id; S : String); + -- Output a warning about the freezing point N of Typ + + function Is_Actual_Of_Instantiation + (E : Entity_Id; + Inst : Node_Id) return Boolean; + -- Return True if E is an actual parameter of instantiation Inst + + ----------------------------------- + -- Output_Freezing_Point_Warning -- + ----------------------------------- + + procedure Freezing_Point_Warning (N : Node_Id; S : String) is + begin + Error_Msg_String (1 .. S'Length) := S; + Error_Msg_Strlen := S'Length; + + if Ada_Version >= Ada_2012 then + Error_Msg_NE ("type& is frozen by ~??", N, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this point??", + N); + + else + Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this point" + & " (Ada 2012)?y?", N); + end if; + end Freezing_Point_Warning; + + -------------------------------- + -- Is_Actual_Of_Instantiation -- + -------------------------------- + + function Is_Actual_Of_Instantiation + (E : Entity_Id; + Inst : Node_Id) return Boolean + is + Assoc : Node_Id; + + begin + if Present (Generic_Associations (Inst)) then + Assoc := First (Generic_Associations (Inst)); + + while Present (Assoc) loop + if Present (Explicit_Generic_Actual_Parameter (Assoc)) + and then + Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc)) + and then + Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E + then + return True; + end if; + + Next (Assoc); + end loop; + end if; + + return False; + end Is_Actual_Of_Instantiation; + + -- Local variable + + Decl : Node_Id; + + -- Start of processing for Check_Untagged_Equality begin - -- This check applies only if we have a subprogram declaration with an - -- untagged record type that is conformant to the predefined operator. + -- This check applies only if we have a subprogram declaration or a + -- subprogram body that is not a completion, for an untagged record + -- type, and that is conformant with the predefined operator. - if Nkind (Decl) /= N_Subprogram_Declaration + if (Nkind (Eq_Decl) /= N_Subprogram_Declaration + and then not (Nkind (Eq_Decl) = N_Subprogram_Body + and then Acts_As_Spec (Eq_Decl))) or else not Is_Record_Type (Typ) or else Is_Tagged_Type (Typ) or else not Is_User_Defined_Equality (Eq_Op) @@ -9560,9 +9647,59 @@ package body Sem_Ch6 is elsif Is_Generic_Actual_Type (Typ) then return; - -- Here we have a definite error of declaration after freezing + -- Here we may have an error of declaration after freezing, but we + -- must make sure not to flag the equality operator itself causing + -- the freezing when it is a subprogram body. else + Decl := Next (Declaration_Node (Typ)); + + while Present (Decl) and then Decl /= Eq_Decl loop + + -- The declaration of an object of the type + + if Nkind (Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Decl)) = Typ + then + Freezing_Point_Warning (Decl, "declaration"); + exit; + + -- The instantiation of a generic on the type + + elsif Nkind (Decl) in N_Generic_Instantiation + and then Is_Actual_Of_Instantiation (Typ, Decl) + then + Freezing_Point_Warning (Decl, "instantiation"); + exit; + + -- A noninstance proper body, body stub or entry body + + elsif Nkind (Decl) in N_Proper_Body + | N_Body_Stub + | N_Entry_Body + and then not Is_Generic_Instance (Defining_Entity (Decl)) + then + Freezing_Point_Warning (Decl, "body"); + exit; + + -- If we have reached the freeze node and immediately after we + -- have the body or generated code for the body, then it is the + -- body that caused the freezing and this is legal. + + elsif Nkind (Decl) = N_Freeze_Entity + and then Entity (Decl) = Typ + and then (Next (Decl) = Eq_Decl + or else + Sloc (Next (Decl)) = Sloc (Eq_Decl)) + then + return; + end if; + + Next (Decl); + end loop; + + -- Here we have a definite error of declaration after freezing + if Ada_Version >= Ada_2012 then Error_Msg_NE ("equality operator must be declared before type & is " @@ -9582,57 +9719,32 @@ package body Sem_Ch6 is & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ); end if; - -- If we are in the package body, we could just move the - -- declaration to the package spec, so add a message saying that. + -- If we have found no freezing point and the declaration of the + -- operator could not be reached from that of the type and we are + -- in a package body, this must be because the type is declared + -- in the spec of the package. Add a message tailored to this. - if In_Package_Body (Scope (Typ)) then + if No (Decl) and then In_Package_Body (Scope (Typ)) then if Ada_Version >= Ada_2012 then - Error_Msg_N - ("\move declaration to package spec<<", Eq_Op); - else - Error_Msg_N - ("\move declaration to package spec (Ada 2012)?y?", Eq_Op); - end if; - - -- Otherwise try to find the freezing point for better message. - - else - Obj_Decl := Next (Parent (Typ)); - while Present (Obj_Decl) and then Obj_Decl /= Decl loop - if Nkind (Obj_Decl) = N_Object_Declaration - and then Etype (Defining_Identifier (Obj_Decl)) = Typ - then - -- Freezing point, output warnings - - if Ada_Version >= Ada_2012 then - Error_Msg_NE - ("type& is frozen by declaration??", Obj_Decl, Typ); - Error_Msg_N - ("\an equality operator cannot be declared after " - & "this point??", - Obj_Decl); - else - Error_Msg_NE - ("type& is frozen by declaration (Ada 2012)?y?", - Obj_Decl, Typ); - Error_Msg_N - ("\an equality operator cannot be declared after " - & "this point (Ada 2012)?y?", - Obj_Decl); - end if; - - exit; - - -- If we reach generated code for subprogram declaration - -- or body, it is the body that froze the type and the - -- declaration is legal. - - elsif Sloc (Obj_Decl) = Sloc (Decl) then - return; + if Nkind (Eq_Decl) = N_Subprogram_Body then + Error_Msg_N + ("\put declaration in package spec<<", Eq_Op); + else + Error_Msg_N + ("\move declaration to package spec<<", Eq_Op); end if; - Next (Obj_Decl); - end loop; + else + if Nkind (Eq_Decl) = N_Subprogram_Body then + Error_Msg_N + ("\put declaration in package spec (Ada 2012)?y?", + Eq_Op); + else + Error_Msg_N + ("\move declaration to package spec (Ada 2012)?y?", + Eq_Op); + end if; + end if; end if; end if; @@ -9641,21 +9753,21 @@ package body Sem_Ch6 is -- a type has been derived from T. else - Obj_Decl := Next (Parent (Typ)); + Decl := Next (Declaration_Node (Typ)); - while Present (Obj_Decl) and then Obj_Decl /= Decl loop - if Nkind (Obj_Decl) = N_Full_Type_Declaration - and then Etype (Defining_Identifier (Obj_Decl)) = Typ + while Present (Decl) and then Decl /= Eq_Decl loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Etype (Defining_Identifier (Decl)) = Typ then Error_Msg_N ("equality operator cannot appear after derivation", Eq_Op); Error_Msg_NE ("an equality operator for& cannot be declared after " & "this point??", - Obj_Decl, Typ); + Decl, Typ); end if; - Next (Obj_Decl); + Next (Decl); end loop; end if; end Check_Untagged_Equality; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 31c04ad..5c347bd 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1253,6 +1253,13 @@ package body Sem_Ch7 is (Context => N, Is_Main_Unit => Parent (N) = Cunit (Main_Unit)); end if; + + -- Warn about references to unset objects, which is straightforward + -- for packages with no bodies. For packages with bodies this is more + -- complicated, because some of the objects might be set between spec + -- and body elaboration, in nested or child packages, etc. + + Check_References (Id); end if; -- Set Body_Required indication on the compilation unit node diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index cda7870..eb9e359 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -10758,15 +10758,26 @@ package body Sem_Ch8 is return; end if; - -- There is a redundant use_type_clause in a child unit. - -- Determine which of the units is more deeply nested. If a + -- If there is a redundant use_type_clause in a child unit + -- determine which of the units is more deeply nested. If a -- unit is a package instance, retrieve the entity and its -- scope from the instance spec. Ent1 := Entity_Of_Unit (Unit1); Ent2 := Entity_Of_Unit (Unit2); - if Scope (Ent2) = Standard_Standard then + -- When the scope of both units' entities are + -- Standard_Standard then neither Unit1 or Unit2 are child + -- units - so return in that case. + + if Scope (Ent1) = Standard_Standard + and then Scope (Ent2) = Standard_Standard + then + return; + + -- Otherwise, determine if one of the units is not a child + + elsif Scope (Ent2) = Standard_Standard then Error_Msg_Sloc := Sloc (Clause2); Err_No := Clause1; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ad43808..df3d348 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6694,7 +6694,7 @@ package body Sem_Prag is 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. + -- exception propagation working. -- Instead the caller should check for N being rewritten as -- a null statement. -- This code triggers when compiling a-except.adb. @@ -10561,7 +10561,7 @@ package body Sem_Prag is -- Check for possible misspelling - for J in Restriction_Id loop + for J in All_Restrictions loop declare Rnm : constant String := Restriction_Id'Image (J); @@ -10792,13 +10792,15 @@ package body Sem_Prag is else R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); - Analyze_And_Resolve (Expr, Any_Integer); if R_Id not in All_Parameter_Restrictions then Error_Pragma_Arg ("invalid restriction parameter identifier", Arg); + end if; - elsif not Is_OK_Static_Expression (Expr) then + Analyze_And_Resolve (Expr, Any_Integer); + + if not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("value must be static expression!", Expr); raise Pragma_Exit; @@ -16997,6 +16999,16 @@ package body Sem_Prag is then Id := Defining_Entity (Stmt); exit; + + -- When pragma Ghost applies to a generic formal type, the + -- type declaration in the instantiation is a generated + -- subtype declaration. + + elsif Nkind (Stmt) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Stmt)) + then + Id := Defining_Entity (Stmt); + exit; end if; -- The pragma applies to a legal construct, stop the traversal diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3ff0afd..44fc955 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -62,6 +62,7 @@ with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; +with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; @@ -2046,16 +2047,18 @@ package body Sem_Res is Full_Analysis := False; Expander_Mode_Save_And_Set (False); + -- See also Preanalyze_And_Resolve in sem.adb for similar handling + -- Normally, we suppress all checks for this preanalysis. There is no -- point in processing them now, since they will be applied properly -- and in the proper location when the default expressions reanalyzed -- and reexpanded later on. We will also have more information at that -- point for possible suppression of individual checks. - -- However, in SPARK mode, most expansion is suppressed, and this - -- later reanalysis and reexpansion may not occur. SPARK mode does + -- However, in GNATprove mode, most expansion is suppressed, and this + -- later reanalysis and reexpansion may not occur. GNATprove mode does -- require the setting of checking flags for proof purposes, so we - -- do the SPARK preanalysis without suppressing checks. + -- do the GNATprove preanalysis without suppressing checks. -- This special handling for SPARK mode is required for example in the -- case of Ada 2012 constructs such as quantified expressions, which are @@ -7191,6 +7194,12 @@ package body Sem_Res is Analyze_Dimension_Call (N, Nam); + -- Check unreachable code after calls to procedures with No_Return + + if Ekind (Nam) = E_Procedure and then No_Return (Nam) then + Check_Unreachable_Code (N); + end if; + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7b7566d..13ffb11 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4868,9 +4868,6 @@ package body Sem_Util is -- and post-state. Prag is a [refined] postcondition or a contract-cases -- pragma. Result_Seen is set when the pragma mentions attribute 'Result - function Is_Trivial_Boolean (N : Node_Id) return Boolean; - -- Determine whether source node N denotes "True" or "False" - ------------------------------------------- -- Check_Result_And_Post_State_In_Pragma -- ------------------------------------------- @@ -5243,20 +5240,6 @@ package body Sem_Util is end if; end Check_Result_And_Post_State_In_Pragma; - ------------------------ - -- Is_Trivial_Boolean -- - ------------------------ - - function Is_Trivial_Boolean (N : Node_Id) return Boolean is - begin - return - Comes_From_Source (N) - and then Is_Entity_Name (N) - and then (Entity (N) = Standard_True - or else - Entity (N) = Standard_False); - end Is_Trivial_Boolean; - -- Local variables Items : constant Node_Id := Contract (Subp_Id); @@ -21501,19 +21484,15 @@ package body Sem_Util is Kind : constant Node_Kind := Nkind (N); begin - if Kind = N_Simple_Return_Statement - or else - Kind = N_Extended_Return_Statement - or else - Kind = N_Goto_Statement - or else - Kind = N_Raise_Statement - or else - Kind = N_Requeue_Statement + if Kind in N_Simple_Return_Statement + | N_Extended_Return_Statement + | N_Goto_Statement + | N_Raise_Statement + | N_Requeue_Statement then return True; - elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error) + elsif Kind in N_Exit_Statement | N_Raise_xxx_Error and then No (Condition (N)) then return True; @@ -21542,6 +21521,17 @@ package body Sem_Util is return No (U) or else U = Uint_1; end Is_True; + ------------------------ + -- Is_Trivial_Boolean -- + ------------------------ + + function Is_Trivial_Boolean (N : Node_Id) return Boolean is + begin + return Comes_From_Source (N) + and then Nkind (N) in N_Identifier | N_Expanded_Name + and then Entity (N) in Standard_True | Standard_False; + end Is_Trivial_Boolean; + -------------------------------------- -- Is_Unchecked_Conversion_Instance -- -------------------------------------- @@ -21896,7 +21886,6 @@ package body Sem_Util is or else (K = E_Component and then not In_Protected_Function (E)) or else (Present (Etype (E)) - and then Is_Access_Object_Type (Etype (E)) and then Is_Access_Variable (Etype (E)) and then Is_Dereferenced (N)) or else K = E_Out_Parameter @@ -23316,7 +23305,7 @@ package body Sem_Util is ------------------------------ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is - pragma Assert (Typ = Underlying_Type (Typ)); + pragma Assert (if Present (Typ) then Typ = Underlying_Type (Typ)); function Depends_On_Discriminant (Typ : Entity_Id) return Boolean; -- Called for untagged record and protected types. Return True if Typ @@ -23353,6 +23342,14 @@ package body Sem_Util is end Depends_On_Discriminant; begin + -- This is a protected type without Corresponding_Record_Type set, + -- typically because expansion is disabled. The safe thing to do is + -- to return True, so Needs_Secondary_Stack returns False. + + if No (Typ) then + return True; + end if; + -- First see if we have a variant part and return False if it depends -- on discriminants. @@ -23378,14 +23375,18 @@ package body Sem_Util is Underlying_Type (Etype (Comp)); begin - if Is_Record_Type (Comp_Type) - or else - Is_Protected_Type (Comp_Type) - then + if Is_Record_Type (Comp_Type) then if not Caller_Known_Size_Record (Comp_Type) then return False; end if; + elsif Is_Protected_Type (Comp_Type) then + if not Caller_Known_Size_Record + (Corresponding_Record_Type (Comp_Type)) + then + return False; + end if; + elsif Is_Array_Type (Comp_Type) then if Size_Depends_On_Discriminant (Comp_Type) then return False; @@ -23489,7 +23490,7 @@ package body Sem_Util is begin -- This is a private type which is not completed yet. This can only -- happen in a default expression (of a formal parameter or of a - -- record component). Do not expand transient scope in this case. + -- record component). The safe thing to do is to return False. if No (Typ) then return False; @@ -23544,12 +23545,17 @@ package body Sem_Util is elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then return Large_Max_Size_Mutable (Typ); - -- Indefinite (discriminated) record or protected type + -- Indefinite (discriminated) record type - elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + elsif Is_Record_Type (Typ) then return not Caller_Known_Size_Record (Typ); - -- Unconstrained array + -- Indefinite (discriminated) protected type + + elsif Is_Protected_Type (Typ) then + return not Caller_Known_Size_Record (Corresponding_Record_Type (Typ)); + + -- Unconstrained array type else pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); @@ -32569,18 +32575,37 @@ package body Sem_Util is Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); begin - pragma Assert (Present (SMT_Aspect_Value)); + -- When the aspect has an aggregate expression, search through it + -- to locate a match for the name of the given "subaspect" and return + -- the entity of the aggregate association's expression. + + if Present (SMT_Aspect_Value) then + Assoc := First (Component_Associations (SMT_Aspect_Value)); + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Nam then + return Entity (Expression (Assoc)); + end if; - Assoc := First (Component_Associations (SMT_Aspect_Value)); - while Present (Assoc) loop - if Chars (First (Choices (Assoc))) = Nam then - return Entity (Expression (Assoc)); - end if; + Next (Assoc); + end loop; + end if; - Next (Assoc); - end loop; + -- The aggregate argument of Storage_Model_Type is optional, and when + -- not present the aspect defaults to the native storage model, where + -- the address type is System.Address. In that case, we return + -- System.Address for Name_Address_Type and System.Null_Address for + -- Name_Null_Address, but return Empty for other cases, and leave it + -- to the back end to map those to the appropriate native operations. - return Empty; + if Nam = Name_Address_Type then + return RTE (RE_Address); + + elsif Nam = Name_Null_Address then + return RTE (RE_Null_Address); + + else + return Empty; + end if; end Get_Storage_Model_Type_Entity; -------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a8afda0..dde5b27 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2481,6 +2481,10 @@ package Sem_Util is -- unconditional transfer of control at run time, i.e. the following -- statement definitely will not be executed. + function Is_Trivial_Boolean (N : Node_Id) return Boolean; + -- Determine whether source node N denotes "True" or "False". Note that + -- this is not true for expressions that got folded to True or False. + function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean; -- Determine whether an arbitrary entity denotes an instance of function -- Ada.Unchecked_Conversion. @@ -3676,21 +3680,26 @@ package Sem_Util is -- Given a type with aspect Storage_Model_Type or an object of such a -- type, and Nam denoting the name of one of the argument kinds allowed -- for that aspect, returns the Entity_Id corresponding to the entity - -- associated with Nam in the aspect. If such an entity is not present, - -- then returns Empty. (Note: This function is modeled on function - -- Get_Iterable_Type_Primitive.) + -- associated with Nam in the aspect. If an entity was not explicitly + -- specified for Nam, then returns Empty, except that in the defaulted + -- Address_Type case, System.Address will be returned, and in the + -- defaulted Null_Address case, System.Null_Address will be returned. + -- (Note: This function is modeled on Get_Iterable_Type_Primitive.) function Storage_Model_Address_Type (SM_Obj_Or_Type : Entity_Id) return Entity_Id; -- Given a type with aspect Storage_Model_Type or an object of such a -- type, returns the type specified for the Address_Type choice in that - -- aspect; returns Empty if the type isn't specified. + -- aspect; returns type System.Address if the address type was not + -- explicitly specified (indicating use of the native memory model). function Storage_Model_Null_Address (SM_Obj_Or_Type : Entity_Id) return Entity_Id; -- Given a type with aspect Storage_Model_Type or an object of such a -- type, returns the constant specified for the Null_Address choice in - -- that aspect; returns Empty if the constant object isn't specified. + -- that aspect; returns Empty if the constant object isn't specified, + -- unless the native memory model is in use (System.Address), in which + -- case it returns System.Null_Address. function Storage_Model_Allocate (SM_Obj_Or_Type : Entity_Id) return Entity_Id; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index a9099e3..ddac1c9 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -554,9 +554,9 @@ package Sinfo is -- The tree after this light expansion should be fully analyzed -- semantically, which sometimes requires the insertion of semantic -- preanalysis, for example for subprogram contracts and pragma - -- check/assert. In particular, all expression must have their proper type, - -- and semantic links should be set between tree nodes (partial to full - -- view, etc.) Some kinds of nodes should be either absent, or can be + -- check/assert. In particular, all expressions must have their proper + -- type, and semantic links should be set between tree nodes (partial to + -- full view, etc.). Some kinds of nodes should be either absent, or can be -- ignored by the formal verification backend: -- N_Object_Renaming_Declaration: can be ignored safely diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index dbf711d..6a16da1 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -274,10 +274,18 @@ package Snames is -- Names for packages that are treated specially by the compiler + Name_Arith_64 : constant Name_Id := N + $; + Name_Arith_128 : constant Name_Id := N + $; Name_Exception_Traces : constant Name_Id := N + $; Name_Finalization : constant Name_Id := N + $; Name_Interfaces : constant Name_Id := N + $; + Name_Memory : constant Name_Id := N + $; + Name_Memory_Compare : constant Name_Id := N + $; + Name_Memory_Copy : constant Name_Id := N + $; + Name_Memory_Move : constant Name_Id := N + $; + Name_Memory_Set : constant Name_Id := N + $; Name_Most_Recent_Exception : constant Name_Id := N + $; + Name_Stack_Checking : constant Name_Id := N + $; Name_Standard : constant Name_Id := N + $; Name_System : constant Name_Id := N + $; Name_Text_IO : constant Name_Id := N + $; @@ -1375,7 +1383,9 @@ package Snames is Name_Has_Element : constant Name_Id := N + $; Name_Forward_Iterator : constant Name_Id := N + $; Name_Reversible_Iterator : constant Name_Id := N + $; + Name_uNext : constant Name_Id := N + $; Name_Previous : constant Name_Id := N + $; + Name_uPrevious : constant Name_Id := N + $; Name_Pseudo_Reference : constant Name_Id := N + $; Name_Reference_Control_Type : constant Name_Id := N + $; Name_Get_Element_Access : constant Name_Id := N + $; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 9ae1797..aae51a2 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -247,6 +247,10 @@ package Types is -- (very often we conditionalize so that we set No_Location in normal mode -- and the corresponding source line in -gnatD mode). + function No (Loc : Source_Ptr) return Boolean is (Loc = No_Location); + function Present (Loc : Source_Ptr) return Boolean is (not No (Loc)); + -- Tests for No_Location / not No_Location + Standard_Location : constant Source_Ptr := -2; -- Used for all nodes in the representation of package Standard other than -- nodes representing the contents of Standard.ASCII. Note that testing for diff --git a/gcc/config/aarch64/aarch64-builtins.cc b/gcc/config/aarch64/aarch64-builtins.cc index e0a741a..4621c6d 100644 --- a/gcc/config/aarch64/aarch64-builtins.cc +++ b/gcc/config/aarch64/aarch64-builtins.cc @@ -2555,121 +2555,6 @@ aarch64_general_expand_builtin (unsigned int fcode, tree exp, rtx target, gcc_unreachable (); } -tree -aarch64_builtin_vectorized_function (unsigned int fn, tree type_out, - tree type_in) -{ - machine_mode in_mode, out_mode; - - if (TREE_CODE (type_out) != VECTOR_TYPE - || TREE_CODE (type_in) != VECTOR_TYPE) - return NULL_TREE; - - out_mode = TYPE_MODE (type_out); - in_mode = TYPE_MODE (type_in); - -#undef AARCH64_CHECK_BUILTIN_MODE -#define AARCH64_CHECK_BUILTIN_MODE(C, N) 1 -#define AARCH64_FIND_FRINT_VARIANT(N) \ - (AARCH64_CHECK_BUILTIN_MODE (2, D) \ - ? aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_##N##v2df] \ - : (AARCH64_CHECK_BUILTIN_MODE (4, S) \ - ? aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_##N##v4sf] \ - : (AARCH64_CHECK_BUILTIN_MODE (2, S) \ - ? aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_##N##v2sf] \ - : NULL_TREE))) - switch (fn) - { -#undef AARCH64_CHECK_BUILTIN_MODE -#define AARCH64_CHECK_BUILTIN_MODE(C, N) \ - (out_mode == V##C##N##Fmode && in_mode == V##C##N##Fmode) - CASE_CFN_FLOOR: - return AARCH64_FIND_FRINT_VARIANT (floor); - CASE_CFN_CEIL: - return AARCH64_FIND_FRINT_VARIANT (ceil); - CASE_CFN_TRUNC: - return AARCH64_FIND_FRINT_VARIANT (btrunc); - CASE_CFN_ROUND: - return AARCH64_FIND_FRINT_VARIANT (round); - CASE_CFN_NEARBYINT: - return AARCH64_FIND_FRINT_VARIANT (nearbyint); - CASE_CFN_SQRT: - return AARCH64_FIND_FRINT_VARIANT (sqrt); -#undef AARCH64_CHECK_BUILTIN_MODE -#define AARCH64_CHECK_BUILTIN_MODE(C, N) \ - (out_mode == V##C##SImode && in_mode == V##C##N##Imode) - CASE_CFN_CLZ: - { - if (AARCH64_CHECK_BUILTIN_MODE (4, S)) - return aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_clzv4si]; - return NULL_TREE; - } - CASE_CFN_CTZ: - { - if (AARCH64_CHECK_BUILTIN_MODE (2, S)) - return aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_ctzv2si]; - else if (AARCH64_CHECK_BUILTIN_MODE (4, S)) - return aarch64_builtin_decls[AARCH64_SIMD_BUILTIN_UNOP_ctzv4si]; - return NULL_TREE; - } -#undef AARCH64_CHECK_BUILTIN_MODE -#define AARCH64_CHECK_BUILTIN_MODE(C, N) \ - (out_mode == V##C##N##Imode && in_mode == V##C##N##Fmode) - CASE_CFN_IFLOOR: - CASE_CFN_LFLOOR: - CASE_CFN_LLFLOOR: - { - enum aarch64_builtins builtin; - if (AARCH64_CHECK_BUILTIN_MODE (2, D)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lfloorv2dfv2di; - else if (AARCH64_CHECK_BUILTIN_MODE (4, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lfloorv4sfv4si; - else if (AARCH64_CHECK_BUILTIN_MODE (2, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lfloorv2sfv2si; - else - return NULL_TREE; - - return aarch64_builtin_decls[builtin]; - } - CASE_CFN_ICEIL: - CASE_CFN_LCEIL: - CASE_CFN_LLCEIL: - { - enum aarch64_builtins builtin; - if (AARCH64_CHECK_BUILTIN_MODE (2, D)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lceilv2dfv2di; - else if (AARCH64_CHECK_BUILTIN_MODE (4, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lceilv4sfv4si; - else if (AARCH64_CHECK_BUILTIN_MODE (2, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lceilv2sfv2si; - else - return NULL_TREE; - - return aarch64_builtin_decls[builtin]; - } - CASE_CFN_IROUND: - CASE_CFN_LROUND: - CASE_CFN_LLROUND: - { - enum aarch64_builtins builtin; - if (AARCH64_CHECK_BUILTIN_MODE (2, D)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lroundv2dfv2di; - else if (AARCH64_CHECK_BUILTIN_MODE (4, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lroundv4sfv4si; - else if (AARCH64_CHECK_BUILTIN_MODE (2, S)) - builtin = AARCH64_SIMD_BUILTIN_UNOP_lroundv2sfv2si; - else - return NULL_TREE; - - return aarch64_builtin_decls[builtin]; - } - default: - return NULL_TREE; - } - - return NULL_TREE; -} - /* Return builtin for reciprocal square root. */ tree @@ -3022,6 +2907,16 @@ aarch64_general_gimple_fold_builtin (unsigned int fcode, gcall *stmt, default: break; } + + /* GIMPLE assign statements (unlike calls) require a non-null lhs. If we + created an assign statement with a null lhs, then fix this by assigning + to a new (and subsequently unused) variable. */ + if (new_stmt && is_gimple_assign (new_stmt) && !gimple_assign_lhs (new_stmt)) + { + tree new_lhs = make_ssa_name (gimple_call_return_type (stmt)); + gimple_assign_set_lhs (new_stmt, new_lhs); + } + return new_stmt; } diff --git a/gcc/config/aarch64/aarch64-protos.h b/gcc/config/aarch64/aarch64-protos.h index dabd047..19c9d3c 100644 --- a/gcc/config/aarch64/aarch64-protos.h +++ b/gcc/config/aarch64/aarch64-protos.h @@ -986,7 +986,6 @@ gimple *aarch64_general_gimple_fold_builtin (unsigned int, gcall *, rtx aarch64_general_expand_builtin (unsigned int, tree, rtx, int); tree aarch64_general_builtin_decl (unsigned, bool); tree aarch64_general_builtin_rsqrt (unsigned int); -tree aarch64_builtin_vectorized_function (unsigned int, tree, tree); void handle_arm_acle_h (void); void handle_arm_neon_h (void); diff --git a/gcc/config/aarch64/aarch64.cc b/gcc/config/aarch64/aarch64.cc index d049f9a..25f4cbb 100644 --- a/gcc/config/aarch64/aarch64.cc +++ b/gcc/config/aarch64/aarch64.cc @@ -27584,10 +27584,6 @@ aarch64_libgcc_floating_mode_supported_p #undef TARGET_VECTORIZE_BUILTINS #define TARGET_VECTORIZE_BUILTINS -#undef TARGET_VECTORIZE_BUILTIN_VECTORIZED_FUNCTION -#define TARGET_VECTORIZE_BUILTIN_VECTORIZED_FUNCTION \ - aarch64_builtin_vectorized_function - #undef TARGET_VECTORIZE_AUTOVECTORIZE_VECTOR_MODES #define TARGET_VECTORIZE_AUTOVECTORIZE_VECTOR_MODES \ aarch64_autovectorize_vector_modes diff --git a/gcc/config/i386/i386.cc b/gcc/config/i386/i386.cc index 95cb1e2..3a3c729 100644 --- a/gcc/config/i386/i386.cc +++ b/gcc/config/i386/i386.cc @@ -24004,6 +24004,7 @@ ix86_optab_supported_p (int op, machine_mode mode1, machine_mode, case ldexp_optab: case scalb_optab: case round_optab: + case lround_optab: return opt_type == OPTIMIZE_FOR_SPEED; case rint_optab: diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index 3b02d0c..bf29f444 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -19926,9 +19926,6 @@ && ((<SWI248x:MODE>mode != DImode) || TARGET_64BIT) && !flag_trapping_math && !flag_rounding_math)" { - if (optimize_insn_for_size_p ()) - FAIL; - if (SSE_FLOAT_MODE_P (<X87MODEF:MODE>mode) && TARGET_SSE_MATH && <SWI248x:MODE>mode != HImode && ((<SWI248x:MODE>mode != DImode) || TARGET_64BIT) diff --git a/gcc/config/xtensa/xtensa.md b/gcc/config/xtensa/xtensa.md index 9d99858..6a58d3e 100644 --- a/gcc/config/xtensa/xtensa.md +++ b/gcc/config/xtensa/xtensa.md @@ -1244,35 +1244,16 @@ "! optimize_debug && reload_completed" [(const_int 0)] { - int i = 0; - rtx x = XEXP (operands[1], 0); - long l[2]; - if (SYMBOL_REF_P (x) - && CONSTANT_POOL_ADDRESS_P (x)) - x = get_pool_constant (x); - else if (GET_CODE (x) == CONST) - { - x = XEXP (x, 0); - gcc_assert (GET_CODE (x) == PLUS - && SYMBOL_REF_P (XEXP (x, 0)) - && CONSTANT_POOL_ADDRESS_P (XEXP (x, 0)) - && CONST_INT_P (XEXP (x, 1))); - i = INTVAL (XEXP (x, 1)); - gcc_assert (i == 0 || i == 4); - i /= 4; - x = get_pool_constant (XEXP (x, 0)); - } - else - gcc_unreachable (); - if (GET_MODE (x) == SFmode) - REAL_VALUE_TO_TARGET_SINGLE (*CONST_DOUBLE_REAL_VALUE (x), l[0]); - else if (GET_MODE (x) == DFmode) - REAL_VALUE_TO_TARGET_DOUBLE (*CONST_DOUBLE_REAL_VALUE (x), l); - else + rtx x = avoid_constant_pool_reference (operands[1]); + long l; + HOST_WIDE_INT value; + if (! CONST_DOUBLE_P (x) || GET_MODE (x) != SFmode) FAIL; + REAL_VALUE_TO_TARGET_SINGLE (*CONST_DOUBLE_REAL_VALUE (x), l); x = gen_rtx_REG (SImode, REGNO (operands[0])); - if (! xtensa_constantsynth (x, l[i])) - emit_move_insn (x, GEN_INT (l[i])); + value = (int32_t)l; + if (! xtensa_constantsynth (x, value)) + emit_move_insn (x, GEN_INT (value)); DONE; }) diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index ad72c03..aa317e8 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,22 @@ +2022-07-13 Patrick Palka <ppalka@redhat.com> + + PR c++/105912 + * pt.cc (tsubst_copy_and_build) <case CALL_EXPR>: Guard against + NULL_TREE extract_call_expr result. + +2022-07-13 Patrick Palka <ppalka@redhat.com> + + PR c++/105842 + * constraint.cc (satisfy_declaration_constraints): Refine early + exit test for argument dependence. + * cp-tree.h (uses_outer_template_parms_in_constraints): Declare. + * pt.cc (template_class_depth): Handle TI_TEMPLATE being a + FIELD_DECL. + (usse_outer_template_parms): Factor out constraint dependence + test into ... + (uses_outer_template_parms_in_constraints): ... here. + (type_dependent_expression_p): Use it for FUNCTION_DECL. + 2022-07-07 Patrick Palka <ppalka@redhat.com> PR c++/105956 diff --git a/gcc/cp/constraint.cc b/gcc/cp/constraint.cc index 591155c..f2137eb 100644 --- a/gcc/cp/constraint.cc +++ b/gcc/cp/constraint.cc @@ -3176,9 +3176,15 @@ satisfy_declaration_constraints (tree t, sat_info info) args = regen_args; } - /* If any arguments depend on template parameters, we can't - check constraints. Pretend they're satisfied for now. */ - if (uses_template_parms (args)) + /* If the innermost arguments are dependent, or if the outer arguments + are dependent and are needed by the constraints, we can't check + satisfaction yet so pretend they're satisfied for now. */ + if (uses_template_parms (args) + && ((DECL_TEMPLATE_INFO (t) + && PRIMARY_TEMPLATE_P (DECL_TI_TEMPLATE (t)) + && (TMPL_ARGS_DEPTH (args) == 1 + || uses_template_parms (INNERMOST_TEMPLATE_ARGS (args)))) + || uses_outer_template_parms_in_constraints (t))) return boolean_true_node; /* Get the normalized constraints. */ @@ -3240,9 +3246,13 @@ satisfy_declaration_constraints (tree t, tree args, sat_info info) else args = add_outermost_template_args (t, args); - /* If any arguments depend on template parameters, we can't - check constraints. Pretend they're satisfied for now. */ - if (uses_template_parms (args)) + /* If the innermost arguments are dependent, or if the outer arguments + are dependent and are needed by the constraints, we can't check + satisfaction yet so pretend they're satisfied for now. */ + if (uses_template_parms (args) + && (TMPL_ARGS_DEPTH (args) == 1 + || uses_template_parms (INNERMOST_TEMPLATE_ARGS (args)) + || uses_outer_template_parms_in_constraints (t))) return boolean_true_node; tree result = boolean_true_node; diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index 2fde4f8..bec98aa 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -7297,6 +7297,7 @@ extern tree lookup_template_function (tree, tree); extern tree lookup_template_variable (tree, tree); extern bool uses_template_parms (tree); extern bool uses_template_parms_level (tree, int); +extern bool uses_outer_template_parms_in_constraints (tree); extern bool in_template_function (void); extern bool need_generic_capture (void); extern tree instantiate_class_template (tree); diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index 59ee50c..718dfa5 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -391,7 +391,9 @@ template_class_depth (tree type) { tree tinfo = get_template_info (type); - if (tinfo && PRIMARY_TEMPLATE_P (TI_TEMPLATE (tinfo)) + if (tinfo + && TREE_CODE (TI_TEMPLATE (tinfo)) == TEMPLATE_DECL + && PRIMARY_TEMPLATE_P (TI_TEMPLATE (tinfo)) && uses_template_parms (INNERMOST_TEMPLATE_ARGS (TI_ARGS (tinfo)))) ++depth; @@ -11011,7 +11013,7 @@ uses_template_parms_level (tree t, int level) /* Returns true if the signature of DECL depends on any template parameter from its enclosing class. */ -bool +static bool uses_outer_template_parms (tree decl) { int depth = template_class_depth (CP_DECL_CONTEXT (decl)); @@ -11042,13 +11044,27 @@ uses_outer_template_parms (tree decl) return true; } } + if (uses_outer_template_parms_in_constraints (decl)) + return true; + return false; +} + +/* Returns true if the constraints of DECL depend on any template parameters + from its enclosing scope. */ + +bool +uses_outer_template_parms_in_constraints (tree decl) +{ tree ci = get_constraints (decl); if (ci) ci = CI_ASSOCIATED_CONSTRAINTS (ci); - if (ci && for_each_template_parm (ci, template_parm_outer_level, - &depth, NULL, /*nondeduced*/true)) - return true; - return false; + if (!ci) + return false; + int depth = template_class_depth (CP_DECL_CONTEXT (decl)); + if (depth == 0) + return false; + return for_each_template_parm (ci, template_parm_outer_level, + &depth, NULL, /*nondeduced*/true); } /* Returns TRUE iff INST is an instantiation we don't need to do in an @@ -21190,12 +21206,12 @@ tsubst_copy_and_build (tree t, bool ord = CALL_EXPR_ORDERED_ARGS (t); bool rev = CALL_EXPR_REVERSE_ARGS (t); if (op || ord || rev) - { - function = extract_call_expr (ret); - CALL_EXPR_OPERATOR_SYNTAX (function) = op; - CALL_EXPR_ORDERED_ARGS (function) = ord; - CALL_EXPR_REVERSE_ARGS (function) = rev; - } + if (tree call = extract_call_expr (ret)) + { + CALL_EXPR_OPERATOR_SYNTAX (call) = op; + CALL_EXPR_ORDERED_ARGS (call) = ord; + CALL_EXPR_REVERSE_ARGS (call) = rev; + } } RETURN (ret); @@ -28103,6 +28119,17 @@ type_dependent_expression_p (tree expression) return false; } + /* Otherwise, its constraints could still depend on outer template parameters + from its (dependent) scope. */ + if (TREE_CODE (expression) == FUNCTION_DECL + /* As an optimization, check this cheaper sufficient condition first. + (At this point we've established that we're looking at a member of + a dependent class, so it makes sense to start treating say undeduced + auto as dependent.) */ + && !dependent_type_p (TREE_TYPE (expression)) + && uses_outer_template_parms_in_constraints (expression)) + return true; + /* Always dependent, on the number of arguments if nothing else. */ if (TREE_CODE (expression) == EXPR_PACK_EXPANSION) return true; diff --git a/gcc/doc/gimple.texi b/gcc/doc/gimple.texi index dd91493..9150218 100644 --- a/gcc/doc/gimple.texi +++ b/gcc/doc/gimple.texi @@ -1965,11 +1965,10 @@ statements to be executed by just the master. @deftypefn {GIMPLE function} gimple gimple_build_omp_ordered (gimple_seq body) Build a @code{GIMPLE_OMP_ORDERED} statement. -@end deftypefn @code{BODY} is the sequence of statements inside a loop that will executed in sequence. - +@end deftypefn @node @code{GIMPLE_OMP_PARALLEL} @subsection @code{GIMPLE_OMP_PARALLEL} diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9bde368..f13ce09 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2022-07-12 Harald Anlauf <anlauf@gmx.de> + + PR fortran/106049 + * simplify.cc (is_constant_array_expr): A non-zero-sized constant + array shall have a non-empty constructor. When the constructor is + empty or missing, treat as non-constant. + 2022-07-04 Tobias Burnus <tobias@codesourcery.com> Jakub Jelinek <jakub@redhat.com> diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index ab59fbc..fb72599 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -233,6 +233,18 @@ is_constant_array_expr (gfc_expr *e) if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) return false; + /* A non-zero-sized constant array shall have a non-empty constructor. */ + if (e->rank > 0 && e->shape != NULL && e->value.constructor == NULL) + { + mpz_init_set_ui (size, 1); + for (int j = 0; j < e->rank; j++) + mpz_mul (size, size, e->shape[j]); + bool not_size0 = (mpz_cmp_si (size, 0) != 0); + mpz_clear (size); + if (not_size0) + return false; + } + for (c = gfc_constructor_first (e->value.constructor); c; c = gfc_constructor_next (c)) if (c->expr->expr_type != EXPR_CONSTANT diff --git a/gcc/go/gofrontend/MERGE b/gcc/go/gofrontend/MERGE index 7c5c456..5ea0406 100644 --- a/gcc/go/gofrontend/MERGE +++ b/gcc/go/gofrontend/MERGE @@ -1,4 +1,4 @@ -d295a0a2c96c0f7c3abd94fea3aa4e2303bf2af2 +ff68b1a147eb60082fd60c198db0ef5477ade938 The first line of this file holds the git revision number of the last merge done from the gofrontend repository. diff --git a/gcc/internal-fn.cc b/gcc/internal-fn.cc index d666ccc..28973d9 100644 --- a/gcc/internal-fn.cc +++ b/gcc/internal-fn.cc @@ -120,6 +120,7 @@ init_internal_fns () #define len_store_direct { 3, 3, false } #define vec_set_direct { 3, 3, false } #define unary_direct { 0, 0, true } +#define unary_convert_direct { -1, 0, true } #define binary_direct { 0, 0, true } #define ternary_direct { 0, 0, true } #define cond_unary_direct { 1, 1, true } @@ -3679,6 +3680,19 @@ expand_while_optab_fn (internal_fn, gcall *stmt, convert_optab optab) emit_move_insn (lhs_rtx, ops[0].value); } +/* Expand a call to a convert-like optab using the operands in STMT. + FN has a single output operand and NARGS input operands. */ + +static void +expand_convert_optab_fn (internal_fn fn, gcall *stmt, convert_optab optab, + unsigned int nargs) +{ + tree_pair types = direct_internal_fn_types (fn, stmt); + insn_code icode = convert_optab_handler (optab, TYPE_MODE (types.first), + TYPE_MODE (types.second)); + expand_fn_using_insn (stmt, icode, 1, nargs); +} + /* Expanders for optabs that can use expand_direct_optab_fn. */ #define expand_unary_optab_fn(FN, STMT, OPTAB) \ @@ -3711,6 +3725,11 @@ expand_while_optab_fn (internal_fn, gcall *stmt, convert_optab optab) #define expand_check_ptrs_optab_fn(FN, STMT, OPTAB) \ expand_direct_optab_fn (FN, STMT, OPTAB, 4) +/* Expanders for optabs that can use expand_convert_optab_fn. */ + +#define expand_unary_convert_optab_fn(FN, STMT, OPTAB) \ + expand_convert_optab_fn (FN, STMT, OPTAB, 1) + /* RETURN_TYPE and ARGS are a return type and argument list that are in principle compatible with FN (which satisfies direct_internal_fn_p). Return the types that should be used to determine whether the @@ -3783,6 +3802,7 @@ multi_vector_optab_supported_p (convert_optab optab, tree_pair types, } #define direct_unary_optab_supported_p direct_optab_supported_p +#define direct_unary_convert_optab_supported_p convert_optab_supported_p #define direct_binary_optab_supported_p direct_optab_supported_p #define direct_ternary_optab_supported_p direct_optab_supported_p #define direct_cond_unary_optab_supported_p direct_optab_supported_p diff --git a/gcc/internal-fn.def b/gcc/internal-fn.def index d2d550d..7c398ba 100644 --- a/gcc/internal-fn.def +++ b/gcc/internal-fn.def @@ -61,6 +61,9 @@ along with GCC; see the file COPYING3. If not see - binary: a normal binary optab, such as vec_interleave_lo_<mode> - ternary: a normal ternary optab, such as fma<mode>4 + - unary_convert: a single-input conversion optab, such as + lround<srcmode><dstmode>2. + - cond_binary: a conditional binary optab, such as cond_add<mode> - cond_ternary: a conditional ternary optab, such as cond_fma_rev<mode> @@ -267,6 +270,26 @@ DEF_INTERNAL_FLT_FLOATN_FN (SQRT, ECF_CONST, sqrt, unary) DEF_INTERNAL_FLT_FN (TAN, ECF_CONST, tan, unary) DEF_INTERNAL_FLT_FN (TANH, ECF_CONST, tanh, unary) +/* Floating-point to integer conversions. + + ??? Here we preserve the I/L/LL prefix convention from the + corresponding built-in functions, rather than make the internal + functions polymorphic in both the argument and the return types. + Perhaps an alternative would be to pass a zero of the required + return type as a second parameter. */ +DEF_INTERNAL_FLT_FN (ICEIL, ECF_CONST, lceil, unary_convert) +DEF_INTERNAL_FLT_FN (IFLOOR, ECF_CONST, lfloor, unary_convert) +DEF_INTERNAL_FLT_FN (IRINT, ECF_CONST, lrint, unary_convert) +DEF_INTERNAL_FLT_FN (IROUND, ECF_CONST, lround, unary_convert) +DEF_INTERNAL_FLT_FN (LCEIL, ECF_CONST, lceil, unary_convert) +DEF_INTERNAL_FLT_FN (LFLOOR, ECF_CONST, lfloor, unary_convert) +DEF_INTERNAL_FLT_FN (LRINT, ECF_CONST, lrint, unary_convert) +DEF_INTERNAL_FLT_FN (LROUND, ECF_CONST, lround, unary_convert) +DEF_INTERNAL_FLT_FN (LLCEIL, ECF_CONST, lceil, unary_convert) +DEF_INTERNAL_FLT_FN (LLFLOOR, ECF_CONST, lfloor, unary_convert) +DEF_INTERNAL_FLT_FN (LLRINT, ECF_CONST, lrint, unary_convert) +DEF_INTERNAL_FLT_FN (LLROUND, ECF_CONST, lround, unary_convert) + /* FP rounding. */ DEF_INTERNAL_FLT_FLOATN_FN (CEIL, ECF_CONST, ceil, unary) DEF_INTERNAL_FLT_FLOATN_FN (FLOOR, ECF_CONST, floor, unary) diff --git a/gcc/optabs.cc b/gcc/optabs.cc index a50dd79..165f8d1 100644 --- a/gcc/optabs.cc +++ b/gcc/optabs.cc @@ -5828,7 +5828,8 @@ expand_sfix_optab (rtx to, rtx from, convert_optab tab) FOR_EACH_MODE_FROM (fmode, GET_MODE (from)) FOR_EACH_MODE_FROM (imode, GET_MODE (to)) { - icode = convert_optab_handler (tab, imode, fmode); + icode = convert_optab_handler (tab, imode, fmode, + insn_optimization_type ()); if (icode != CODE_FOR_nothing) { rtx_insn *last = get_last_insn (); diff --git a/gcc/predict.cc b/gcc/predict.cc index b36caa3..1bc7ab9 100644 --- a/gcc/predict.cc +++ b/gcc/predict.cc @@ -362,6 +362,17 @@ optimize_insn_for_speed_p (void) return !optimize_insn_for_size_p (); } +/* Return the optimization type that should be used for the current + instruction. */ + +optimization_type +insn_optimization_type () +{ + return (optimize_insn_for_speed_p () + ? OPTIMIZE_FOR_SPEED + : OPTIMIZE_FOR_SIZE); +} + /* Return TRUE if LOOP should be optimized for size. */ optimize_size_level diff --git a/gcc/predict.h b/gcc/predict.h index 8649974..2548437 100644 --- a/gcc/predict.h +++ b/gcc/predict.h @@ -68,6 +68,7 @@ extern enum optimize_size_level optimize_edge_for_size_p (edge); extern bool optimize_edge_for_speed_p (edge); extern enum optimize_size_level optimize_insn_for_size_p (void); extern bool optimize_insn_for_speed_p (void); +extern optimization_type insn_optimization_type (); extern enum optimize_size_level optimize_loop_for_size_p (class loop *); extern bool optimize_loop_for_speed_p (class loop *); extern bool optimize_loop_nest_for_speed_p (class loop *); diff --git a/gcc/range-op.cc b/gcc/range-op.cc index 5150c60..e184129 100644 --- a/gcc/range-op.cc +++ b/gcc/range-op.cc @@ -803,6 +803,9 @@ operator_lt::fold_range (irange &r, tree type, r = range_true (type); else if (!wi::lt_p (op1.lower_bound (), op2.upper_bound (), sign)) r = range_false (type); + // Use nonzero bits to determine if < 0 is false. + else if (op2.zero_p () && !wi::neg_p (op1.get_nonzero_bits (), sign)) + r = range_false (type); else r = range_true_and_false (type); return true; @@ -2604,72 +2607,8 @@ private: void simple_op1_range_solver (irange &r, tree type, const irange &lhs, const irange &op2) const; - void remove_impossible_ranges (irange &r, const irange &rh) const; } op_bitwise_and; -static bool -unsigned_singleton_p (const irange &op) -{ - tree mask; - if (op.singleton_p (&mask)) - { - wide_int x = wi::to_wide (mask); - return wi::ge_p (x, 0, TYPE_SIGN (op.type ())); - } - return false; -} - -// Remove any ranges from R that are known to be impossible when an -// range is ANDed with MASK. - -void -operator_bitwise_and::remove_impossible_ranges (irange &r, - const irange &rmask) const -{ - if (r.undefined_p () || !unsigned_singleton_p (rmask)) - return; - - wide_int mask = rmask.lower_bound (); - tree type = r.type (); - int prec = TYPE_PRECISION (type); - int leading_zeros = wi::clz (mask); - int_range_max impossible_ranges; - - /* We know that starting at the most significant bit, any 0 in the - mask means the resulting range cannot contain a 1 in that same - position. This means the following ranges are impossible: - - x & 0b1001 1010 - IMPOSSIBLE RANGES - 01xx xxxx [0100 0000, 0111 1111] - 001x xxxx [0010 0000, 0011 1111] - 0000 01xx [0000 0100, 0000 0111] - 0000 0001 [0000 0001, 0000 0001] - */ - wide_int one = wi::one (prec); - for (int i = 0; i < prec - leading_zeros - 1; ++i) - if (wi::bit_and (mask, wi::lshift (one, wi::uhwi (i, prec))) == 0) - { - tree lb = fold_build2 (LSHIFT_EXPR, type, - build_one_cst (type), - build_int_cst (type, i)); - tree ub_left = fold_build1 (BIT_NOT_EXPR, type, - fold_build2 (LSHIFT_EXPR, type, - build_minus_one_cst (type), - build_int_cst (type, i))); - tree ub_right = fold_build2 (LSHIFT_EXPR, type, - build_one_cst (type), - build_int_cst (type, i)); - tree ub = fold_build2 (BIT_IOR_EXPR, type, ub_left, ub_right); - impossible_ranges.union_ (int_range<1> (lb, ub)); - } - if (!impossible_ranges.undefined_p ()) - { - impossible_ranges.invert (); - r.intersect (impossible_ranges); - } -} - bool operator_bitwise_and::fold_range (irange &r, tree type, const irange &lh, @@ -2678,9 +2617,9 @@ operator_bitwise_and::fold_range (irange &r, tree type, { if (range_operator::fold_range (r, type, lh, rh)) { - // FIXME: This is temporarily disabled because, though it - // generates better ranges, it's noticeably slower for evrp. - // remove_impossible_ranges (r, rh); + if (!lh.undefined_p () && !rh.undefined_p ()) + r.set_nonzero_bits (wi::bit_and (lh.get_nonzero_bits (), + rh.get_nonzero_bits ())); return true; } return false; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7b95680..97b9f5f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,60 @@ +2022-07-13 Patrick Palka <ppalka@redhat.com> + + PR c++/105912 + * g++.dg/cpp2a/consteval31.C: New test. + +2022-07-13 Patrick Palka <ppalka@redhat.com> + + PR c++/105842 + * g++.dg/cpp2a/concepts-memtmpl6.C: New test. + +2022-07-13 Aldy Hernandez <aldyh@redhat.com> + + * g++.dg/ipa/pure-const-3.C: Adjust. + * gcc.dg/pr102983.c: Adjust. + +2022-07-13 Andrew Carlotti <andrew.carlotti@arm.com> + + * gcc.target/aarch64/advsimd-intrinsics/ignored_return_1.c: New test. + +2022-07-13 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106249 + * gcc.dg/pr106249.c: New testcase. + +2022-07-12 Harald Anlauf <anlauf@gmx.de> + + PR fortran/106049 + * gfortran.dg/pack_simplify_1.f90: New test. + +2022-07-12 Richard Sandiford <richard.sandiford@arm.com> + + PR target/106253 + * gcc.target/aarch64/vect_unary_1.c: Add tests for iroundf, + llround, iceilf, llceil, ifloorf, llfloor, irintf and llrint. + * gfortran.dg/vect/pr106253.f: New test. + +2022-07-12 Piotr Trojanek <trojanek@adacore.com> + + * gnat.dg/specs/discr5.ads: Expect new warnings. + * gnat.dg/specs/empty_variants.ads: Likewise. + * gnat.dg/specs/pack13.ads: Likewise. + +2022-07-12 Richard Sandiford <richard.sandiford@arm.com> + + * gcc.target/aarch64/vect_unary_1.c: New test. + +2022-07-12 Alexandre Oliva <oliva@adacore.com> + + * gcc.target/i386/cet-sjlj-6a.c: Cope with --enable-default-pie. + * gcc.target/i386/cet-sjlj-6b.c: Likewise. + * gcc.target/i386/fentryname3.c: Likewise. + * gcc.target/i386/mvc7.c: Likewise. + * gcc.target/i386/pr24414.c: Likewise. + * gcc.target/i386/pr93492-3.c: Likewise. + * gcc.target/i386/pr93492-5.c: Likewise. + * gcc.target/i386/pr98482-1.c: Likewise. + 2022-07-11 Roger Sayle <roger@nextmovesoftware.com> * gcc.target/i386/sse4_1-stv-2.c: New test case, pand. diff --git a/gcc/testsuite/g++.dg/cpp2a/concepts-memtmpl6.C b/gcc/testsuite/g++.dg/cpp2a/concepts-memtmpl6.C new file mode 100644 index 0000000..0e09ae6 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/concepts-memtmpl6.C @@ -0,0 +1,34 @@ +// PR c++/105842 +// { dg-do compile { target c++20 } } + +template<class T> +struct S { + static void func1() requires __is_same(T, int); + static void func1() requires (!__is_same(T, int)); + + static void func2() requires false && false; + static void func2() requires false; + + template<class...> static void tmpl1() requires __is_same(T, int); + template<class...> static void tmpl1() requires (!__is_same(T, int)); + + template<class... Us> static void tmpl2() requires (sizeof...(Us) == 1); + template<class... Us> static void tmpl2() requires (sizeof...(Us) == 2); + + static void foo() { + // Both calls resolve to the first overload at instantiation time. + func1(); + tmpl1(); + } + + static void bar() { + // We can check and reject both calls ahead of time since the functions' + // constraints don't depend on outer template parameters. + func2(); // { dg-error "no match" } + tmpl2(); // { dg-error "no match" } + } +}; + +int main() { + S<int>::foo(); +} diff --git a/gcc/testsuite/g++.dg/cpp2a/consteval31.C b/gcc/testsuite/g++.dg/cpp2a/consteval31.C new file mode 100644 index 0000000..85a4d17 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/consteval31.C @@ -0,0 +1,26 @@ +// PR c++/105912 +// { dg-do compile { target c++20 } } + +struct A { + consteval A operator+() { + return {}; + } +}; + +consteval A operator~(A) { + return {}; +} + +consteval A operator+(A, A) { + return {}; +} + +template<class> +void f() { + A a; + ~a; + a + a; + +a; +} + +template void f<int>(); diff --git a/gcc/testsuite/g++.dg/ipa/pure-const-3.C b/gcc/testsuite/g++.dg/ipa/pure-const-3.C index 172a36b..b4a4673 100644 --- a/gcc/testsuite/g++.dg/ipa/pure-const-3.C +++ b/gcc/testsuite/g++.dg/ipa/pure-const-3.C @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fno-ipa-vrp -fdump-tree-optimized -fno-tree-ccp" } */ +/* { dg-options "-O2 -fno-ipa-vrp -fdump-tree-optimized -fno-tree-ccp -fdisable-tree-evrp" } */ int *ptr; static int barvar; static int b(int a); diff --git a/gcc/testsuite/gcc.dg/pr102983.c b/gcc/testsuite/gcc.dg/pr102983.c index ef58af6..e1bd24b 100644 --- a/gcc/testsuite/gcc.dg/pr102983.c +++ b/gcc/testsuite/gcc.dg/pr102983.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-evrp" } */ +/* { dg-options "-O2 -fdump-tree-evrp -fno-tree-ccp" } */ void foo(void); static int a = 1; diff --git a/gcc/testsuite/gcc.dg/pr106249.c b/gcc/testsuite/gcc.dg/pr106249.c new file mode 100644 index 0000000..f97b07f --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr106249.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-O -floop-unroll-and-jam --param unroll-jam-min-percent=0" } */ + +void +foo (double *arr) +{ + int i, j; + + for (i = 0; i < 4; ++i) + for (j = 0; j < 4; ++j) + arr[j] = 0; + + for (i = 1; i < 4; ++i) + for (j = 0; j < 4; ++j) + arr[j] = 1.0 / (i + 1); +} diff --git a/gcc/testsuite/gcc.target/aarch64/advsimd-intrinsics/ignored_return_1.c b/gcc/testsuite/gcc.target/aarch64/advsimd-intrinsics/ignored_return_1.c new file mode 100644 index 0000000..3453074 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/advsimd-intrinsics/ignored_return_1.c @@ -0,0 +1,9 @@ +/* { dg-do compile { target { aarch64*-*-* } } } */ + +#include <arm_neon.h> + +int8_t *bar(); + +void foo() { + __builtin_aarch64_ld1v16qi(bar()); +} diff --git a/gcc/testsuite/gcc.target/aarch64/vect_unary_1.c b/gcc/testsuite/gcc.target/aarch64/vect_unary_1.c new file mode 100644 index 0000000..94d9af1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/vect_unary_1.c @@ -0,0 +1,249 @@ +/* { dg-options "-O3 -fno-math-errno --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#include <stdint.h> + +#define TEST2(OUT, NAME, IN) \ +OUT __attribute__((vector_size(sizeof(OUT) * 2))) \ +test2_##OUT##_##NAME##_##IN (float dummy, \ + IN __attribute__((vector_size(sizeof(IN) * 2))) y) \ +{ \ + OUT __attribute__((vector_size(sizeof(OUT) * 2))) x; \ + x[0] = __builtin_##NAME (y[0]); \ + x[1] = __builtin_##NAME (y[1]); \ + return x; \ +} \ + +#define TEST4(OUT, NAME, IN) \ +OUT __attribute__((vector_size(16))) \ +test4_##OUT##_##NAME##_##IN (float dummy, \ + IN __attribute__((vector_size(16))) y) \ +{ \ + OUT __attribute__((vector_size(16))) x; \ + x[0] = __builtin_##NAME (y[0]); \ + x[1] = __builtin_##NAME (y[1]); \ + x[2] = __builtin_##NAME (y[2]); \ + x[3] = __builtin_##NAME (y[3]); \ + return x; \ +} \ + +/* +** test2_float_truncf_float: +** frintz v0.2s, v1.2s +** ret +*/ +TEST2 (float, truncf, float) + +/* +** test2_double_trunc_double: +** frintz v0.2d, v1.2d +** ret +*/ +TEST2 (double, trunc, double) + +/* +** test4_float_truncf_float: +** frintz v0.4s, v1.4s +** ret +*/ +TEST4 (float, truncf, float) + +/* +** test2_float_roundf_float: +** frinta v0.2s, v1.2s +** ret +*/ +TEST2 (float, roundf, float) + +/* +** test2_double_round_double: +** frinta v0.2d, v1.2d +** ret +*/ +TEST2 (double, round, double) + +/* +** test4_float_roundf_float: +** frinta v0.4s, v1.4s +** ret +*/ +TEST4 (float, roundf, float) + +/* +** test2_float_nearbyintf_float: +** frinti v0.2s, v1.2s +** ret +*/ +TEST2 (float, nearbyintf, float) + +/* +** test2_double_nearbyint_double: +** frinti v0.2d, v1.2d +** ret +*/ +TEST2 (double, nearbyint, double) + +/* +** test4_float_nearbyintf_float: +** frinti v0.4s, v1.4s +** ret +*/ +TEST4 (float, nearbyintf, float) + +/* +** test2_float_floorf_float: +** frintm v0.2s, v1.2s +** ret +*/ +TEST2 (float, floorf, float) + +/* +** test2_double_floor_double: +** frintm v0.2d, v1.2d +** ret +*/ +TEST2 (double, floor, double) + +/* +** test4_float_floorf_float: +** frintm v0.4s, v1.4s +** ret +*/ +TEST4 (float, floorf, float) + +/* +** test2_float_ceilf_float: +** frintp v0.2s, v1.2s +** ret +*/ +TEST2 (float, ceilf, float) + +/* +** test2_double_ceil_double: +** frintp v0.2d, v1.2d +** ret +*/ +TEST2 (double, ceil, double) + +/* +** test4_float_ceilf_float: +** frintp v0.4s, v1.4s +** ret +*/ +TEST4 (float, ceilf, float) + +/* +** test2_float_rintf_float: +** frintx v0.2s, v1.2s +** ret +*/ +TEST2 (float, rintf, float) + +/* +** test2_double_rint_double: +** frintx v0.2d, v1.2d +** ret +*/ +TEST2 (double, rint, double) + +/* +** test4_float_rintf_float: +** frintx v0.4s, v1.4s +** ret +*/ +TEST4 (float, rintf, float) + +/* +** test2_int_clz_int: +** clz v0.2s, v1.2s +** ret +*/ +TEST2 (int, clz, int) + +/* +** test4_int_clz_int: +** clz v0.4s, v1.4s +** ret +*/ +TEST4 (int, clz, int) + +/* +** test2_int_ctz_int: +** rev32 (v[0-9]+).8b, v1.8b +** rbit (v[0-9]+).8b, \1.8b +** clz v0.2s, \2.2s +** ret +*/ +TEST2 (int, ctz, int) + +/* +** test4_int_ctz_int: +** rev32 (v[0-9]+).16b, v1.16b +** rbit (v[0-9]+).16b, \1.16b +** clz v0.4s, \2.4s +** ret +*/ +TEST4 (int, ctz, int) + +/* +** test2_int_iroundf_float: +** fcvtas v0.2s, v1.2s +** ret +*/ +TEST2 (int, iroundf, float) + +/* +** test2_int64_t_llround_double: +** fcvtas v0.2d, v1.2d +** ret +*/ +TEST2 (int64_t, llround, double) + +/* +** test4_int_iroundf_float: +** fcvtas v0.4s, v1.4s +** ret +*/ +TEST4 (int, iroundf, float) + +/* +** test2_int_ifloorf_float: +** fcvtms v0.2s, v1.2s +** ret +*/ +TEST2 (int, ifloorf, float) + +/* +** test2_int64_t_llfloor_double: +** fcvtms v0.2d, v1.2d +** ret +*/ +TEST2 (int64_t, llfloor, double) + +/* +** test4_int_ifloorf_float: +** fcvtms v0.4s, v1.4s +** ret +*/ +TEST4 (int, ifloorf, float) + +/* +** test2_int_iceilf_float: +** fcvtps v0.2s, v1.2s +** ret +*/ +TEST2 (int, iceilf, float) + +/* +** test2_int64_t_llceil_double: +** fcvtps v0.2d, v1.2d +** ret +*/ +TEST2 (int64_t, llceil, double) + +/* +** test4_int_iceilf_float: +** fcvtps v0.4s, v1.4s +** ret +*/ +TEST4 (int, iceilf, float) diff --git a/gcc/testsuite/gcc.target/i386/cet-sjlj-6a.c b/gcc/testsuite/gcc.target/i386/cet-sjlj-6a.c index 040b297..c3d0eb9 100644 --- a/gcc/testsuite/gcc.target/i386/cet-sjlj-6a.c +++ b/gcc/testsuite/gcc.target/i386/cet-sjlj-6a.c @@ -2,8 +2,10 @@ /* { dg-require-effective-target maybe_x32 } */ /* { dg-options "-O -maddress-mode=short -fcf-protection -mx32" } */ /* { dg-final { scan-assembler-times "endbr64" 2 } } */ -/* { dg-final { scan-assembler-times "movq\t.*buf\\+8" 1 } } */ -/* { dg-final { scan-assembler-times "subq\tbuf\\+8" 1 } } */ +/* { dg-final { scan-assembler-times "movq\t\[^\n\]*buf\\+8" 1 { target nonpic } } } */ +/* { dg-final { scan-assembler-times "movq\t\[^\n\]*8\\+buf" 1 { target { ! nonpic } } } } */ +/* { dg-final { scan-assembler-times "subq\tbuf\\+8" 1 { target nonpic } } } */ +/* { dg-final { scan-assembler-times "subq\t8\\+buf" 1 { target { ! nonpic } } } } */ /* { dg-final { scan-assembler-times "shrl\t\\\$3," 1 } } */ /* { dg-final { scan-assembler-times "rdsspq" 2 } } */ /* { dg-final { scan-assembler-times "incsspq" 2 } } */ diff --git a/gcc/testsuite/gcc.target/i386/cet-sjlj-6b.c b/gcc/testsuite/gcc.target/i386/cet-sjlj-6b.c index b2376e7..4c52685 100644 --- a/gcc/testsuite/gcc.target/i386/cet-sjlj-6b.c +++ b/gcc/testsuite/gcc.target/i386/cet-sjlj-6b.c @@ -2,8 +2,10 @@ /* { dg-require-effective-target maybe_x32 } */ /* { dg-options "-O -maddress-mode=long -fcf-protection -mx32" } */ /* { dg-final { scan-assembler-times "endbr64" 2 } } */ -/* { dg-final { scan-assembler-times "movq\t.*buf\\+16" 1 } } */ -/* { dg-final { scan-assembler-times "subq\tbuf\\+16" 1 } } */ +/* { dg-final { scan-assembler-times "movq\t\[^\n\]*buf\\+16" 1 { target nonpic } } } */ +/* { dg-final { scan-assembler-times "movq\t\[^\n\]*16\\+buf" 1 { target { ! nonpic } } } } */ +/* { dg-final { scan-assembler-times "subq\tbuf\\+16" 1 { target nonpic } } } */ +/* { dg-final { scan-assembler-times "subq\t16\\+buf" 1 { target { ! nonpic } } } } */ /* { dg-final { scan-assembler-times "shrl\t\\\$3," 1 } } */ /* { dg-final { scan-assembler-times "rdsspq" 2 } } */ /* { dg-final { scan-assembler-times "incsspq" 2 } } */ diff --git a/gcc/testsuite/gcc.target/i386/fentryname3.c b/gcc/testsuite/gcc.target/i386/fentryname3.c index bd7c997..c14a4eb 100644 --- a/gcc/testsuite/gcc.target/i386/fentryname3.c +++ b/gcc/testsuite/gcc.target/i386/fentryname3.c @@ -3,7 +3,8 @@ /* { dg-require-profiling "-pg" } */ /* { dg-options "-pg -mfentry" } */ /* { dg-final { scan-assembler "section.*__entry_loc" } } */ -/* { dg-final { scan-assembler "0x0f, 0x1f, 0x44, 0x00, 0x00" } } */ +/* { dg-final { scan-assembler "0x0f, 0x1f, 0x44, 0x00, 0x00" { target nonpic } } } */ +/* { dg-final { scan-assembler "call\t\\*nop@GOTPCREL" { target { ! nonpic } } } } */ /* { dg-final { scan-assembler-not "__fentry__" } } */ __attribute__((fentry_name("nop"), fentry_section("__entry_loc"))) diff --git a/gcc/testsuite/gcc.target/i386/mvc7.c b/gcc/testsuite/gcc.target/i386/mvc7.c index 7fb9dde..872cd59 100644 --- a/gcc/testsuite/gcc.target/i386/mvc7.c +++ b/gcc/testsuite/gcc.target/i386/mvc7.c @@ -2,12 +2,12 @@ /* { dg-require-ifunc "" } */ /* Verify that foo clones are not numbered. */ -/* { dg-final { scan-assembler "foo.resolver," } } */ -/* { dg-final { scan-assembler "foo.default," } } */ -/* { dg-final { scan-assembler "foo.avx," } } */ - -/* { dg-final { scan-assembler "slm" } } */ -/* { dg-final { scan-assembler "foo,foo.resolver" } } */ +/* { dg-final { scan-assembler "foo\.resolver," } } */ +/* { dg-final { scan-assembler "foo\.default\[,@\]" } } */ +/* { dg-final { scan-assembler "foo\.avx\[,@\]" } } */ +/* { dg-final { scan-assembler "foo\.arch_core_avx2\[,@\]" } } */ +/* { dg-final { scan-assembler "foo\.arch_slm\[,@\]" } } */ +/* { dg-final { scan-assembler "foo,foo\.resolver" } } */ __attribute__((target_clones("avx","default","arch=slm","arch=core-avx2"))) int foo (); diff --git a/gcc/testsuite/gcc.target/i386/pr24414.c b/gcc/testsuite/gcc.target/i386/pr24414.c index 0acaa00..6f77fa9 100644 --- a/gcc/testsuite/gcc.target/i386/pr24414.c +++ b/gcc/testsuite/gcc.target/i386/pr24414.c @@ -1,4 +1,5 @@ /* { dg-do run } */ +/* { dg-require-effective-target nonpic } */ /* { dg-options "-O2" } */ /* { dg-skip-if "asm insert mismatches ABI for Darwin" { *-*-darwin* } } */ int test; diff --git a/gcc/testsuite/gcc.target/i386/pr93492-3.c b/gcc/testsuite/gcc.target/i386/pr93492-3.c index 52a19e5..a625c92 100644 --- a/gcc/testsuite/gcc.target/i386/pr93492-3.c +++ b/gcc/testsuite/gcc.target/i386/pr93492-3.c @@ -10,4 +10,4 @@ f10_endbr (void) { } -/* { dg-final { scan-assembler "\t\.cfi_startproc\n\tendbr(32|64)\n.*\.LPFE1:\n\tnop\n1:\tcall\t__fentry__\n\tret\n" } } */ +/* { dg-final { scan-assembler "\t\.cfi_startproc\n\tendbr(32|64)\n.*\.LPFE1:\n\tnop\n1:\tcall\t\[^\n\]*__fentry__\[^\n\]*\n\tret\n" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr93492-5.c b/gcc/testsuite/gcc.target/i386/pr93492-5.c index fcf4ad4..5aebb38 100644 --- a/gcc/testsuite/gcc.target/i386/pr93492-5.c +++ b/gcc/testsuite/gcc.target/i386/pr93492-5.c @@ -8,4 +8,4 @@ foo (void) { } -/* { dg-final { scan-assembler "\t\.cfi_startproc\n.*\.LPFE1:\n\tnop\n1:\tcall\t__fentry__\n\tret\n" } } */ +/* { dg-final { scan-assembler "\t\.cfi_startproc\n.*\.LPFE1:\n\tnop\n1:\tcall\t\[^\n\]*__fentry__\[^\n\]*\n\tret\n" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr98482-1.c b/gcc/testsuite/gcc.target/i386/pr98482-1.c index 912cbe0..b1d9619 100644 --- a/gcc/testsuite/gcc.target/i386/pr98482-1.c +++ b/gcc/testsuite/gcc.target/i386/pr98482-1.c @@ -1,7 +1,8 @@ /* { dg-do compile { target { *-*-linux* && lp64 } } } */ /* { dg-require-effective-target mfentry } */ /* { dg-options "-fprofile -mfentry -O2 -mcmodel=large" } */ -/* { dg-final { scan-assembler "movabsq\t\\\$__fentry__, %r10\n\tcall\t\\*%r10" } } */ +/* { dg-final { scan-assembler "movabsq\t\\\$__fentry__, %r10\n\tcall\t\\*%r10" { target nonpic } } } */ +/* { dg-final { scan-assembler "movabsq\t\\\$__fentry__@PLTOFF, %r11\n\taddq\t%r11, %r10\n\tcall\t\\*%r10" { target { ! nonpic } } } } */ void func (void) diff --git a/gcc/testsuite/gcc.target/xtensa/constsynth_double.c b/gcc/testsuite/gcc.target/xtensa/constsynth_double.c index 890ca50..5fba6a9 100644 --- a/gcc/testsuite/gcc.target/xtensa/constsynth_double.c +++ b/gcc/testsuite/gcc.target/xtensa/constsynth_double.c @@ -5,7 +5,7 @@ void test(unsigned int count, double array[]) { unsigned int i; for (i = 0; i < count; ++i) - array[i] = 1.0; + array[i] = 8.988474246316506e+307; } /* { dg-final { scan-assembler-not "l32r" } } */ diff --git a/gcc/testsuite/gfortran.dg/pack_simplify_1.f90 b/gcc/testsuite/gfortran.dg/pack_simplify_1.f90 new file mode 100644 index 0000000..06bc55a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pack_simplify_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/106049 - ICE in gfc_simplify_pack +! Contributed by G.Steinmetz + +program p + type t + end type + logical, parameter :: m(0) = [ logical :: ] + type(t), parameter :: a(0) = [ t :: ] + type(t), parameter :: b(1) = [ t() ] + type(t), parameter :: c(1) = [ t :: ] ! { dg-error "Different shape" } + type(t), parameter :: d(0) = pack(a, m) + type(t), parameter :: e(1) = pack(b, [.true.]) + type(t), parameter :: f(1) = pack(c, [.true.]) +end diff --git a/gcc/testsuite/gfortran.dg/vect/pr106253.f b/gcc/testsuite/gfortran.dg/vect/pr106253.f new file mode 100644 index 0000000..1b6b7e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/pr106253.f @@ -0,0 +1,35 @@ +! { dg-do compile } + + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, & + & BETA, Y, INCY ) + LOGICAL LSAME + IF ( .NOT.LSAME( TRANS, 'N' ).AND. & + & .NOT.LSAME( TRANS, 'C' ) )THEN + END IF + END + subroutine evlrnf (ptrs0t, nclsm, prnf0t) + real, dimension (1:nclsm,1:nclsm), intent (in) :: ptrs0t + real, dimension (1:nclsm,1:nclsm), intent (out):: prnf0t + real, allocatable, dimension (:,:) :: utrsft ! probas up + real, allocatable, dimension (:,:) :: dtrsft ! probas down + real, allocatable, dimension (:,:) :: xwrkt ! matrice + do icls = 1, nclsm + do ival = ipic - 1, 1, -1 + xwrkt = trs2a2 (ival, ipic, utrsft, dtrsft, ncls) + enddo + enddo + contains + function trs2a2 (j, k, u, d, m) + real, dimension (1:m,1:m) :: trs2a2 ! resultat + real, dimension (1:m,1:m) :: u, d ! matrices utrsft, dtrsft + end function trs2a2 + end + program rnflow + integer, parameter :: ncls = 256 ! nombre de classes + integer, dimension (1:ncls,1:ncls) :: mrnftt ! matrice theorique + real, dimension (1:ncls,1:ncls) :: ptrst ! matrice Markov + real, dimension (1:ncls,1:ncls) :: prnft ! matrice Rainflow + call evlrnf (ptrst, ncls, prnft) + mrnftt = nint (real (nsim) * real (npic) * prnft) + call cmpmat (mrnftt, mrnfst) + end program rnflow diff --git a/gcc/testsuite/gnat.dg/specs/discr5.ads b/gcc/testsuite/gnat.dg/specs/discr5.ads index c265723..79c234a 100644 --- a/gcc/testsuite/gnat.dg/specs/discr5.ads +++ b/gcc/testsuite/gnat.dg/specs/discr5.ads @@ -22,7 +22,7 @@ package Discr5 is subtype Rt is R(True); subtype Rf is R(False); - type R1 (D1 : Boolean) is new R (X) with record + type R1 (D1 : Boolean) is new R (X) with record -- { dg-warning "\"X\" may be referenced before it has a value" } FF : Float; case D1 is when True => @@ -38,7 +38,7 @@ package Discr5 is subtype R1t is R1 (True); subtype R1f is R1 (False); - type R2 (D2 : Boolean) is new R1 (Y) with record + type R2 (D2 : Boolean) is new R1 (Y) with record -- { dg-warning "\"Y\" may be referenced before it has a value" } FFF: System.Address; case D2 is when True => @@ -55,3 +55,4 @@ package Discr5 is subtype R2f is R2 (False); end Discr5; + diff --git a/gcc/testsuite/gnat.dg/specs/empty_variants.ads b/gcc/testsuite/gnat.dg/specs/empty_variants.ads index 079b64a..9b0cdad 100644 --- a/gcc/testsuite/gnat.dg/specs/empty_variants.ads +++ b/gcc/testsuite/gnat.dg/specs/empty_variants.ads @@ -1,5 +1,4 @@ -- { dg-do compile } --- { dg-options "-gnatdF" } package Empty_Variants is @@ -23,10 +22,11 @@ package Empty_Variants is R : Rec; - I : Integer := R.I; + I : Integer := R.I; -- { dg-warning "\"R\.I\" may be referenced before it has a value" } J : Integer := R.J; K : Integer := R.K; L : Integer := R.L; M : Integer := R.L; end Empty_Variants; + diff --git a/gcc/testsuite/gnat.dg/specs/pack13.ads b/gcc/testsuite/gnat.dg/specs/pack13.ads index 4594ab7..8614550 100644 --- a/gcc/testsuite/gnat.dg/specs/pack13.ads +++ b/gcc/testsuite/gnat.dg/specs/pack13.ads @@ -20,6 +20,6 @@ package Pack13 is A : Arr; - package My_G is new G (Boolean, A(True).B); + package My_G is new G (Boolean, A(True).B); -- { dg-warning "\"A\" may be referenced before it has a value" } end Pack13; diff --git a/gcc/tree-ssa-dom.cc b/gcc/tree-ssa-dom.cc index 43acc75..f5e8f57 100644 --- a/gcc/tree-ssa-dom.cc +++ b/gcc/tree-ssa-dom.cc @@ -112,7 +112,8 @@ static void record_equality (tree, tree, class const_and_copies *); static void record_equivalences_from_phis (basic_block); static void record_equivalences_from_incoming_edge (basic_block, class const_and_copies *, - class avail_exprs_stack *); + class avail_exprs_stack *, + bitmap blocks_on_stack); static void eliminate_redundant_computations (gimple_stmt_iterator *, class const_and_copies *, class avail_exprs_stack *); @@ -120,6 +121,8 @@ static void record_equivalences_from_stmt (gimple *, int, class avail_exprs_stack *); static void dump_dominator_optimization_stats (FILE *file, hash_table<expr_elt_hasher> *); +static void record_temporary_equivalences (edge, class const_and_copies *, + class avail_exprs_stack *, bitmap); /* Constructor for EDGE_INFO. An EDGE_INFO instance is always associated with an edge E. */ @@ -591,6 +594,7 @@ public: dom_jt_state (const_and_copies *copies, avail_exprs_stack *avails) : m_copies (copies), m_avails (avails) { + bitmap_tree_view (m_blocks_on_stack); } void push (edge e) override { @@ -606,12 +610,16 @@ public: } void register_equivs_edge (edge e) override { - record_temporary_equivalences (e, m_copies, m_avails); + record_temporary_equivalences (e, m_copies, m_avails, m_blocks_on_stack); } void register_equiv (tree dest, tree src, bool update) override; + bitmap get_blocks_on_stack () { return m_blocks_on_stack; } private: const_and_copies *m_copies; avail_exprs_stack *m_avails; + /* Set of blocks on the stack, to be used for medium-fast + dominance queries in back_propagate_equivalences. */ + auto_bitmap m_blocks_on_stack; }; void @@ -653,7 +661,7 @@ class dom_opt_dom_walker : public dom_walker public: dom_opt_dom_walker (cdi_direction direction, jump_threader *threader, - jt_state *state, + dom_jt_state *state, gimple_ranger *ranger, const_and_copies *const_and_copies, avail_exprs_stack *avail_exprs_stack) @@ -693,7 +701,7 @@ private: jump_threader *m_threader; gimple_ranger *m_ranger; - jt_state *m_state; + dom_jt_state *m_state; }; /* Jump threading, redundancy elimination and const/copy propagation. @@ -962,7 +970,7 @@ dom_valueize (tree t) static void back_propagate_equivalences (tree lhs, edge e, class const_and_copies *const_and_copies, - bitmap *domby) + bitmap domby) { use_operand_p use_p; imm_use_iterator iter; @@ -997,29 +1005,12 @@ back_propagate_equivalences (tree lhs, edge e, } else { - /* Profiling has shown the domination tests here can be fairly - expensive when the fast indexes are not computed. - We get significant improvements by building the - set of blocks that dominate BB. We can then just test - for set membership below. - - We also initialize the set lazily since often the only uses - are going to be in the same block as DEST. */ - - if (!*domby) - { - *domby = BITMAP_ALLOC (NULL); - bitmap_tree_view (*domby); - basic_block bb = get_immediate_dominator (CDI_DOMINATORS, dest); - while (bb) - { - bitmap_set_bit (*domby, bb->index); - bb = get_immediate_dominator (CDI_DOMINATORS, bb); - } - } - + /* We can use the set of BBs on the stack from a domwalk + for a medium fast way to query dominance. Profiling + has shown non-fast query dominance tests here can be fairly + expensive. */ /* This tests if USE_STMT does not dominate DEST. */ - if (!bitmap_bit_p (*domby, gimple_bb (use_stmt)->index)) + if (!bitmap_bit_p (domby, gimple_bb (use_stmt)->index)) continue; } @@ -1037,10 +1028,11 @@ back_propagate_equivalences (tree lhs, edge e, by traversing edge E (which are cached in E->aux). Callers are responsible for managing the unwinding markers. */ -void +static void record_temporary_equivalences (edge e, class const_and_copies *const_and_copies, - class avail_exprs_stack *avail_exprs_stack) + class avail_exprs_stack *avail_exprs_stack, + bitmap blocks_on_stack) { int i; class edge_info *edge_info = (class edge_info *) e->aux; @@ -1055,7 +1047,6 @@ record_temporary_equivalences (edge e, for (i = 0; edge_info->cond_equivalences.iterate (i, &eq); ++i) avail_exprs_stack->record_cond (eq); - bitmap domby = NULL; edge_info::equiv_pair *seq; for (i = 0; edge_info->simple_equivalences.iterate (i, &seq); ++i) { @@ -1092,10 +1083,9 @@ record_temporary_equivalences (edge e, /* Any equivalence found for LHS may result in additional equivalences for other uses of LHS that we have already processed. */ - back_propagate_equivalences (lhs, e, const_and_copies, &domby); + back_propagate_equivalences (lhs, e, const_and_copies, + blocks_on_stack); } - if (domby) - BITMAP_FREE (domby); } } @@ -1267,7 +1257,8 @@ dom_opt_dom_walker::set_global_ranges_from_unreachable_edges (basic_block bb) static void record_equivalences_from_incoming_edge (basic_block bb, class const_and_copies *const_and_copies, - class avail_exprs_stack *avail_exprs_stack) + class avail_exprs_stack *avail_exprs_stack, + bitmap blocks_on_stack) { edge e; basic_block parent; @@ -1282,7 +1273,8 @@ record_equivalences_from_incoming_edge (basic_block bb, /* If we had a single incoming edge from our parent block, then enter any data associated with the edge into our tables. */ if (e && e->src == parent) - record_temporary_equivalences (e, const_and_copies, avail_exprs_stack); + record_temporary_equivalences (e, const_and_copies, avail_exprs_stack, + blocks_on_stack); } /* Dump statistics for the hash table HTAB. */ @@ -1517,9 +1509,11 @@ dom_opt_dom_walker::before_dom_children (basic_block bb) far to unwind when we finalize this block. */ m_avail_exprs_stack->push_marker (); m_const_and_copies->push_marker (); + bitmap_set_bit (m_state->get_blocks_on_stack (), bb->index); record_equivalences_from_incoming_edge (bb, m_const_and_copies, - m_avail_exprs_stack); + m_avail_exprs_stack, + m_state->get_blocks_on_stack ()); set_global_ranges_from_unreachable_edges (bb); /* PHI nodes can create equivalences too. */ @@ -1594,6 +1588,7 @@ void dom_opt_dom_walker::after_dom_children (basic_block bb) { m_threader->thread_outgoing_edges (bb); + bitmap_clear_bit (m_state->get_blocks_on_stack (), bb->index); m_avail_exprs_stack->pop_to_marker (); m_const_and_copies->pop_to_marker (); } diff --git a/gcc/tree-ssa-dom.h b/gcc/tree-ssa-dom.h index 9df8307..98154c5 100644 --- a/gcc/tree-ssa-dom.h +++ b/gcc/tree-ssa-dom.h @@ -21,8 +21,5 @@ along with GCC; see the file COPYING3. If not see #define GCC_TREE_SSA_DOM_H extern bool simple_iv_increment_p (gimple *); -extern void record_temporary_equivalences (edge, - class const_and_copies *, - class avail_exprs_stack *); #endif /* GCC_TREE_SSA_DOM_H */ diff --git a/gcc/tree-ssa-loop-manip.cc b/gcc/tree-ssa-loop-manip.cc index c531f1f..410a851 100644 --- a/gcc/tree-ssa-loop-manip.cc +++ b/gcc/tree-ssa-loop-manip.cc @@ -1208,7 +1208,7 @@ tree_transform_and_unroll_loop (class loop *loop, unsigned factor, profile_probability::guessed_always (), true); gcc_assert (new_loop != NULL); - update_ssa (TODO_update_ssa); + update_ssa (TODO_update_ssa_no_phi); /* Prepare the cfg and update the phi nodes. Move the loop exit to the loop latch (and make its condition dummy, for the moment). */ @@ -1428,7 +1428,8 @@ tree_transform_and_unroll_loop (class loop *loop, unsigned factor, checking_verify_flow_info (); checking_verify_loop_structure (); checking_verify_loop_closed_ssa (true, loop); - checking_verify_loop_closed_ssa (true, new_loop); + if (new_loop) + checking_verify_loop_closed_ssa (true, new_loop); } /* Wrapper over tree_transform_and_unroll_loop for case we do not diff --git a/gcc/tree-vect-loop-manip.cc b/gcc/tree-vect-loop-manip.cc index 2c2b4f7..86d2264 100644 --- a/gcc/tree-vect-loop-manip.cc +++ b/gcc/tree-vect-loop-manip.cc @@ -1332,56 +1332,6 @@ slpeel_can_duplicate_loop_p (const class loop *loop, const_edge e) return true; } -/* If the loop has a virtual PHI, but exit bb doesn't, create a virtual PHI - in the exit bb and rename all the uses after the loop. This simplifies - the *guard[12] routines, which assume loop closed SSA form for all PHIs - (but normally loop closed SSA form doesn't require virtual PHIs to be - in the same form). Doing this early simplifies the checking what - uses should be renamed. - - If we create a new phi after the loop, return the definition that - applies on entry to the loop, otherwise return null. */ - -static tree -create_lcssa_for_virtual_phi (class loop *loop) -{ - gphi_iterator gsi; - edge exit_e = single_exit (loop); - - for (gsi = gsi_start_phis (loop->header); !gsi_end_p (gsi); gsi_next (&gsi)) - if (virtual_operand_p (gimple_phi_result (gsi_stmt (gsi)))) - { - gphi *phi = gsi.phi (); - for (gsi = gsi_start_phis (exit_e->dest); - !gsi_end_p (gsi); gsi_next (&gsi)) - if (virtual_operand_p (gimple_phi_result (gsi_stmt (gsi)))) - break; - if (gsi_end_p (gsi)) - { - tree new_vop = copy_ssa_name (PHI_RESULT (phi)); - gphi *new_phi = create_phi_node (new_vop, exit_e->dest); - tree vop = PHI_ARG_DEF_FROM_EDGE (phi, EDGE_SUCC (loop->latch, 0)); - imm_use_iterator imm_iter; - gimple *stmt; - use_operand_p use_p; - - SSA_NAME_OCCURS_IN_ABNORMAL_PHI (new_vop) - = SSA_NAME_OCCURS_IN_ABNORMAL_PHI (vop); - add_phi_arg (new_phi, vop, exit_e, UNKNOWN_LOCATION); - gimple_phi_set_result (new_phi, new_vop); - FOR_EACH_IMM_USE_STMT (stmt, imm_iter, vop) - if (stmt != new_phi - && !flow_bb_inside_loop_p (loop, gimple_bb (stmt))) - FOR_EACH_IMM_USE_ON_STMT (use_p, imm_iter) - SET_USE (use_p, new_vop); - - return PHI_ARG_DEF_FROM_EDGE (phi, loop_preheader_edge (loop)); - } - break; - } - return NULL_TREE; -} - /* Function vect_get_loop_location. Extract the location of the loop in the source code. @@ -2702,31 +2652,20 @@ vect_do_peeling (loop_vec_info loop_vinfo, tree niters, tree nitersm1, pending update needs. */ gcc_assert (!need_ssa_update_p (cfun)); - create_lcssa_for_virtual_phi (loop); - - /* If we're vectorizing an epilogue loop, the update_ssa above will - have ensured that the virtual operand is in SSA form throughout the - vectorized main loop. Normally it is possible to trace the updated + /* If we're vectorizing an epilogue loop, we have ensured that the + virtual operand is in SSA form throughout the vectorized main loop. + Normally it is possible to trace the updated vector-stmt vdefs back to scalar-stmt vdefs and vector-stmt vuses back to scalar-stmt vuses, meaning that the effect of the SSA update remains local to the main loop. However, there are rare cases in - which the vectorized loop has vdefs even when the original scalar + which the vectorized loop should have vdefs even when the original scalar loop didn't. For example, vectorizing a load with IFN_LOAD_LANES introduces clobbers of the temporary vector array, which in turn needs new vdefs. If the scalar loop doesn't write to memory, these new vdefs will be the only ones in the vector loop. - - In that case, update_ssa will have added a new virtual phi to the - main loop, which previously didn't need one. Ensure that we (locally) - maintain LCSSA form for the virtual operand, just as we would have - done if the virtual phi had existed from the outset. This makes it - easier to duplicate the scalar epilogue loop below. */ - tree vop_to_rename = NULL_TREE; - if (loop_vec_info orig_loop_vinfo = LOOP_VINFO_ORIG_LOOP_INFO (loop_vinfo)) - { - class loop *orig_loop = LOOP_VINFO_LOOP (orig_loop_vinfo); - vop_to_rename = create_lcssa_for_virtual_phi (orig_loop); - } + We are currently defering updating virtual SSA form and creating + of a virtual PHI for this case so we do not have to make sure the + newly introduced virtual def is in LCSSA form. */ if (MAY_HAVE_DEBUG_BIND_STMTS) { @@ -2947,26 +2886,6 @@ vect_do_peeling (loop_vec_info loop_vinfo, tree niters, tree nitersm1, as the transformations mentioned above make less or no sense when not vectorizing. */ epilog = vect_epilogues ? get_loop_copy (loop) : scalar_loop; - if (vop_to_rename) - { - /* Vectorizing the main loop can sometimes introduce a vdef to - a loop that previously didn't have one; see the comment above - the definition of VOP_TO_RENAME for details. The definition - D that holds on E will then be different from the definition - VOP_TO_RENAME that holds during SCALAR_LOOP, so we need to - rename VOP_TO_RENAME to D when copying the loop. - - The virtual operand is in LCSSA form for the main loop, - and no stmt between the main loop and E needs a vdef, - so we know that D is provided by a phi rather than by a - vdef on a normal gimple stmt. */ - basic_block vdef_bb = e->src; - gphi *vphi; - while (!(vphi = get_virtual_phi (vdef_bb))) - vdef_bb = get_immediate_dominator (CDI_DOMINATORS, vdef_bb); - gcc_assert (vop_to_rename != gimple_phi_result (vphi)); - set_current_def (vop_to_rename, gimple_phi_result (vphi)); - } epilog = slpeel_tree_duplicate_loop_to_edge_cfg (loop, epilog, e); if (!epilog) { diff --git a/gcc/value-range.cc b/gcc/value-range.cc index a02fab4..528ed54 100644 --- a/gcc/value-range.cc +++ b/gcc/value-range.cc @@ -331,6 +331,7 @@ irange::copy_to_legacy (const irange &src) m_base[0] = src.m_base[0]; m_base[1] = src.m_base[1]; m_kind = src.m_kind; + m_nonzero_mask = src.m_nonzero_mask; return; } // Copy multi-range to legacy. @@ -1336,6 +1337,9 @@ irange::legacy_intersect (irange *vr0, const irange *vr1) intersect_ranges (&vr0kind, &vr0min, &vr0max, vr1->kind (), vr1->min (), vr1->max ()); + // Pessimize nonzero masks, as we don't support them. + m_nonzero_mask = NULL; + /* Make sure to canonicalize the result though as the inversion of a VR_RANGE can still be a VR_RANGE. */ if (vr0kind == VR_UNDEFINED) @@ -1657,6 +1661,9 @@ irange::legacy_union (irange *vr0, const irange *vr1) union_ranges (&vr0kind, &vr0min, &vr0max, vr1->kind (), vr1->min (), vr1->max ()); + // Pessimize nonzero masks, as we don't support them. + m_nonzero_mask = NULL; + if (vr0kind == VR_UNDEFINED) vr0->set_undefined (); else if (vr0kind == VR_VARYING) @@ -2253,6 +2260,7 @@ irange::invert () } gcc_checking_assert (!undefined_p () && !varying_p ()); + m_nonzero_mask = NULL; // We always need one more set of bounds to represent an inverse, so // if we're at the limit, we can't properly represent things. @@ -2388,10 +2396,6 @@ wide_int irange::get_nonzero_bits () const { gcc_checking_assert (!undefined_p ()); - // Nonzero bits are unsupported in legacy mode. The mask may be set - // as a consequence of propagation or reading global ranges, but no - // one from legacy land should be querying this. - gcc_checking_assert (!legacy_mode_p ()); // Calculate the nonzero bits inherent in the range. wide_int min = lower_bound (); @@ -2509,7 +2513,7 @@ irange::dump (FILE *file) const void irange::dump_bitmasks (FILE *file) const { - if (m_nonzero_mask && !legacy_mode_p ()) + if (m_nonzero_mask) { wide_int nz = get_nonzero_bits (); if (nz != -1) diff --git a/include/ChangeLog b/include/ChangeLog index 07f2b7c..ee23c30 100644 --- a/include/ChangeLog +++ b/include/ChangeLog @@ -1,3 +1,10 @@ +2022-07-12 Martin Liska <mliska@suse.cz> + + * plugin-api.h (enum linker_api_version): New enum. + (ld_plugin_get_api_version): New. + (enum ld_plugin_tag): Add LDPT_GET_API_VERSION. + (struct ld_plugin_tv): Add tv_get_api_version. + 2022-07-06 Thomas Schwinge <thomas@codesourcery.com> * gomp-constants.h (OMP_REQUIRES_[...]): Update comment. diff --git a/include/plugin-api.h b/include/plugin-api.h index 8aebe2f..0b61cfc 100644 --- a/include/plugin-api.h +++ b/include/plugin-api.h @@ -483,6 +483,37 @@ enum ld_plugin_level LDPL_FATAL }; +/* Contract between a plug-in and a linker. */ + +enum linker_api_version +{ + /* The linker/plugin do not implement any of the API levels below, the API + is determined solely via the transfer vector. */ + LAPI_V0, + + /* API level v1. The linker provides get_symbols_v3, add_symbols_v2, + the plugin will use that and not any lower versions. + claim_file is thread-safe on the plugin side and + add_symbols on the linker side. */ + LAPI_V1 +}; + +/* The linker's interface for API version negotiation. A plug-in calls + the function (with its IDENTIFIER and VERSION), plus minimal and maximal + version of linker_api_version is provided. Linker then returns selected + API version and provides its IDENTIFIER and VERSION. The returned value + by linker must be in range [MINIMAL_API_SUPPORTED, MAXIMAL_API_SUPPORTED]. + Identifier pointers remain valid as long as the plugin is loaded. */ + +typedef +int +(*ld_plugin_get_api_version) (const char *plugin_identifier, + const char *plugin_version, + int minimal_api_supported, + int maximal_api_supported, + const char **linker_identifier, + const char **linker_version); + /* Values for the tv_tag field of the transfer vector. */ enum ld_plugin_tag @@ -521,6 +552,7 @@ enum ld_plugin_tag LDPT_REGISTER_NEW_INPUT_HOOK, LDPT_GET_WRAP_SYMBOLS, LDPT_ADD_SYMBOLS_V2, + LDPT_GET_API_VERSION, }; /* The plugin transfer vector. */ @@ -556,6 +588,7 @@ struct ld_plugin_tv ld_plugin_get_input_section_size tv_get_input_section_size; ld_plugin_register_new_input tv_register_new_input; ld_plugin_get_wrap_symbols tv_get_wrap_symbols; + ld_plugin_get_api_version tv_get_api_version; } tv_u; }; diff --git a/libcpp/ChangeLog b/libcpp/ChangeLog index 1a211f32..fe02298 100644 --- a/libcpp/ChangeLog +++ b/libcpp/ChangeLog @@ -1,3 +1,9 @@ +2022-07-13 Marek Polacek <polacek@redhat.com> + + PR preprocessor/106272 + * include/line-map.h (class label_text): Don't std::move in a return + statement. + 2022-07-10 Lewis Hyatt <lhyatt@gmail.com> PR preprocessor/97498 diff --git a/libcpp/include/line-map.h b/libcpp/include/line-map.h index c6379ce..c434a24 100644 --- a/libcpp/include/line-map.h +++ b/libcpp/include/line-map.h @@ -1873,13 +1873,13 @@ public: longer-lived owner. */ static label_text borrow (const char *buffer) { - return std::move (label_text (const_cast <char *> (buffer), false)); + return label_text (const_cast <char *> (buffer), false); } /* Create a label_text instance that takes ownership of BUFFER. */ static label_text take (char *buffer) { - return std::move (label_text (buffer, true)); + return label_text (buffer, true); } /* Take ownership of the buffer, copying if necessary. */ diff --git a/libgo/sysinfo.c b/libgo/sysinfo.c index a4259c0..fc02109 100644 --- a/libgo/sysinfo.c +++ b/libgo/sysinfo.c @@ -158,9 +158,6 @@ #if defined(HAVE_LINUX_ETHER_H) #include <linux/ether.h> #endif -#if defined(HAVE_LINUX_FS_H) -#include <linux/fs.h> -#endif #if defined(HAVE_LINUX_REBOOT_H) #include <linux/reboot.h> #endif diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index f2a282c..5a836a9 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,13 @@ +2022-07-12 Tobias Burnus <tobias@codesourcery.com> + + * target.c (gomp_target_init): Added tailing '\n' to gomp_debug. + +2022-07-12 Thomas Schwinge <thomas@codesourcery.com> + + PR middle-end/101551 + * testsuite/libgomp.oacc-c-c++-common/reduction-5.c: XFAIL + 'offloading_enabled' diagnostics issue. + 2022-07-11 Thomas Schwinge <thomas@codesourcery.com> * testsuite/libgomp.oacc-c-c++-common/reduction-5.c: Enhance diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 6abc8fe..5f0bbd7 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,25 @@ +2022-07-12 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/106248 + * include/std/istream [C++17] (operator>>(istream&, char*)): + Set eofbit if we stopped extracting at EOF. + * testsuite/27_io/basic_istream/extractors_character/char/pr106248.cc: + New test. + * testsuite/27_io/basic_istream/extractors_character/wchar_t/pr106248.cc: + New test. + +2022-07-12 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/stl_iterator.h (__iter_to_alloc_t): Replace + add_const_t with const-qualifier. + * include/bits/utility.h (tuple_element<N, cv T>): Likewise for + all cv-qualifiers. + * include/std/type_traits (add_const, add_volatile): Replace + typedef-declaration with using-declaration. + (add_cv): Replace add_const and add_volatile with cv-qualifiers. + * include/std/variant (variant_alternative<N, cv T>): Replace + add_const_t, add_volatile_t and add_cv_t etc. with cv-qualifiers. + 2022-07-09 François Dumont <fdumont@gcc.gnu.org> * include/std/string: Remove obsolete comment about char_traits.h including diff --git a/libstdc++-v3/include/std/istream b/libstdc++-v3/include/std/istream index b506c4f..416ef55 100644 --- a/libstdc++-v3/include/std/istream +++ b/libstdc++-v3/include/std/istream @@ -784,7 +784,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION * - if `width()` is greater than zero, `n` is `min(width(), n)` * - otherwise `n` is the number of elements of the array * - (before C++20 the pointer is assumed to point to an array of - * - the largest possible size for an array of `char_type`). + * the largest possible size for an array of `char_type`). * * Characters are extracted and stored until one of the following happens: * - `n - 1` characters are stored @@ -802,19 +802,40 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION inline basic_istream<_CharT, _Traits>& operator>>(basic_istream<_CharT, _Traits>& __in, _CharT* __s) { +#ifdef __OPTIMIZE__ + // Function inlining might make the buffer size known, allowing us to + // prevent overflow. size_t __n = __builtin_object_size(__s, 0); - if (__builtin_expect(__n < sizeof(_CharT), false)) + if (__n < sizeof(_CharT)) { // There is not even space for the required null terminator. __glibcxx_assert(__n >= sizeof(_CharT)); + // No point calling __istream_extract, but still need to reset width. __in.width(0); __in.setstate(ios_base::failbit); } + else if (__n != (size_t)-1) + { + __n /= sizeof(_CharT); + streamsize __w = __in.width(); + std::__istream_extract(__in, __s, __n); + if (__in.good() && (__w <= 0 || __n < __w)) + { + // Stopped extracting early to avoid overflowing the buffer, + // but might have stopped anyway (and set eofbit) if at EOF. + const typename _Traits::int_type __c = __in.rdbuf()->sgetc(); + const bool __eof = _Traits::eq_int_type(__c, _Traits::eof()); + if (__builtin_expect(__eof, true)) // Assume EOF, not overflow. + __in.setstate(ios_base::eofbit); + } + } else +#endif // __OPTIMIZE { - if (__n == (size_t)-1) - __n = __gnu_cxx::__numeric_traits<streamsize>::__max; - std::__istream_extract(__in, __s, __n / sizeof(_CharT)); + // Buffer size is unknown, have to assume it's huge. + streamsize __n = __gnu_cxx::__numeric_traits<streamsize>::__max; + __n /= sizeof(_CharT); + std::__istream_extract(__in, __s, __n); } return __in; } diff --git a/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/char/pr106248.cc b/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/char/pr106248.cc new file mode 100644 index 0000000..6d89a0e --- /dev/null +++ b/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/char/pr106248.cc @@ -0,0 +1,40 @@ +// { dg-do run } + +#include <sstream> +#include <testsuite_hooks.h> + +void +test_pr106248() +{ + char buf[5] = {'x', 'x', 'x', 'x', 'x'}; + std::string s(" four"); + std::istringstream in(s); + in >> buf; +#if __cplusplus >= 202002L + // Extraction stops because buffer is full. + VERIFY( in.good() ); +#else + // PR libstdc++/106248 + // Extraction stops because all input has been consumed and eofbit is set. + VERIFY( in.eof() ); +#endif + // Extracted string must be null-terminated. + VERIFY( buf[4] == '\0' ); + VERIFY( std::string(buf) == "four" ); + + in.clear(); + in.str(s); + for (int i = 0; i < 5; ++i) + s[i] = 'x'; + + in.width(5); + in >> buf; + // Extraction stops due to field width, eofbit not set. + VERIFY( in.good() ); + VERIFY( std::string(buf) == "four" ); +} + +int main() +{ + test_pr106248(); +} diff --git a/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/wchar_t/pr106248.cc b/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/wchar_t/pr106248.cc new file mode 100644 index 0000000..7c22660 --- /dev/null +++ b/libstdc++-v3/testsuite/27_io/basic_istream/extractors_character/wchar_t/pr106248.cc @@ -0,0 +1,40 @@ +// { dg-do run } + +#include <sstream> +#include <testsuite_hooks.h> + +void +test_pr106248() +{ + wchar_t buf[5] = {L'x', L'x', L'x', L'x', L'x'}; + std::wstring s(L" four"); + std::wistringstream in(s); + in >> buf; +#if __cplusplus >= 202002L + // Extraction stops because buffer is full. + VERIFY( in.good() ); +#else + // PR libstdc++/106248 + // Extraction stops because all input has been consumed and eofbit is set. + VERIFY( in.eof() ); +#endif + // Extracted string must be null-terminated. + VERIFY( buf[4] == L'\0' ); + VERIFY( std::wstring(buf) == L"four" ); + + in.clear(); + in.str(s); + for (int i = 0; i < 5; ++i) + s[i] = L'x'; + + in.width(5); + in >> buf; + // Extraction stops due to field width, eofbit not set. + VERIFY( in.good() ); + VERIFY( std::wstring(buf) == L"four" ); +} + +int main() +{ + test_pr106248(); +} diff --git a/lto-plugin/ChangeLog b/lto-plugin/ChangeLog index 16e44c8..42760af 100644 --- a/lto-plugin/ChangeLog +++ b/lto-plugin/ChangeLog @@ -1,3 +1,10 @@ +2022-07-12 Martin Liska <mliska@suse.cz> + + * lto-plugin.c (negotiate_api_version): New. + (onload): Negotiate API version. + * Makefile.am: Add -DBASE_VERSION. + * Makefile.in: Regenerate. + 2022-07-07 Martin Liska <mliska@suse.cz> PR lto/106170 diff --git a/lto-plugin/Makefile.am b/lto-plugin/Makefile.am index 81362ea..482946e 100644 --- a/lto-plugin/Makefile.am +++ b/lto-plugin/Makefile.am @@ -8,7 +8,7 @@ target_noncanonical := @target_noncanonical@ libexecsubdir := $(libexecdir)/gcc/$(real_target_noncanonical)/$(gcc_version)$(accel_dir_suffix) AM_CPPFLAGS = -I$(top_srcdir)/../include $(DEFS) -AM_CFLAGS = @ac_lto_plugin_warn_cflags@ $(CET_HOST_FLAGS) +AM_CFLAGS = @ac_lto_plugin_warn_cflags@ $(CET_HOST_FLAGS) -DBASE_VERSION='"$(gcc_version)"' # The plug-in depends on pthreads. AM_LDFLAGS = -pthread @ac_lto_plugin_ldflags@ AM_LIBTOOLFLAGS = --tag=disable-static diff --git a/lto-plugin/Makefile.in b/lto-plugin/Makefile.in index 2033dd9..9453bc7 100644 --- a/lto-plugin/Makefile.in +++ b/lto-plugin/Makefile.in @@ -343,7 +343,7 @@ AUTOMAKE_OPTIONS = no-dependencies gcc_version := $(shell @get_gcc_base_ver@ $(top_srcdir)/../gcc/BASE-VER) libexecsubdir := $(libexecdir)/gcc/$(real_target_noncanonical)/$(gcc_version)$(accel_dir_suffix) AM_CPPFLAGS = -I$(top_srcdir)/../include $(DEFS) -AM_CFLAGS = @ac_lto_plugin_warn_cflags@ $(CET_HOST_FLAGS) +AM_CFLAGS = @ac_lto_plugin_warn_cflags@ $(CET_HOST_FLAGS) -DBASE_VERSION='"$(gcc_version)"' # The plug-in depends on pthreads. AM_LDFLAGS = -pthread @ac_lto_plugin_ldflags@ AM_LIBTOOLFLAGS = --tag=disable-static diff --git a/lto-plugin/lto-plugin.c b/lto-plugin/lto-plugin.c index 7927dca..e9afd2f 100644 --- a/lto-plugin/lto-plugin.c +++ b/lto-plugin/lto-plugin.c @@ -180,6 +180,10 @@ static ld_plugin_add_input_file add_input_file; static ld_plugin_add_input_library add_input_library; static ld_plugin_message message; static ld_plugin_add_symbols add_symbols, add_symbols_v2; +static ld_plugin_get_api_version get_api_version; + +/* By default, use version LAPI_V0 if there is not negotiation. */ +static enum linker_api_version api_version = LAPI_V0; static struct plugin_file_info *claimed_files = NULL; static unsigned int num_claimed_files = 0; @@ -1428,6 +1432,43 @@ process_option (const char *option) verbose = verbose || debug; } +/* Negotiate linker API version. */ + +static void +negotiate_api_version (void) +{ + const char *linker_identifier; + const char *linker_version; + + enum linker_api_version supported_api = LAPI_V0; +#if HAVE_PTHREAD_LOCKING + supported_api = LAPI_V1; +#endif + + api_version = get_api_version ("GCC", BASE_VERSION, LAPI_V0, + supported_api, &linker_identifier, &linker_version); + if (api_version > supported_api) + { + fprintf (stderr, "requested an unsupported API version (%d)\n", api_version); + abort (); + } + + switch (api_version) + { + case LAPI_V0: + break; + case LAPI_V1: + check (get_symbols_v3, LDPL_FATAL, + "get_symbols_v3 required for API version 1"); + check (add_symbols_v2, LDPL_FATAL, + "add_symbols_v2 required for API version 1"); + break; + default: + fprintf (stderr, "unsupported API version (%d)\n", api_version); + abort (); + } +} + /* Called by a linker after loading the plugin. TV is the transfer vector. */ enum ld_plugin_status @@ -1496,12 +1537,18 @@ onload (struct ld_plugin_tv *tv) /* We only use this to make user-friendly temp file names. */ link_output_name = p->tv_u.tv_string; break; + case LDPT_GET_API_VERSION: + get_api_version = p->tv_u.tv_get_api_version; + break; default: break; } p++; } + if (get_api_version) + negotiate_api_version (); + check (register_claim_file, LDPL_FATAL, "register_claim_file not found"); check (add_symbols, LDPL_FATAL, "add_symbols not found"); status = register_claim_file (claim_file_handler); |